{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
{-# LANGUAGE DeriveDataTypeable #-}

module HsBinds where

import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
			       MatchGroup, pprFunBind,
			       GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat  ( LPat )

import HsTypes
import PprCore ()
import Coercion
import Type
import Name
import NameSet
import BasicTypes
import Outputable	
import SrcLoc
import Util
import VarEnv
import Var
import Bag
import Unique
import FastString

import Data.IORef( IORef )
import Data.Data hiding ( Fixity )

-- During renaming, we need bindings where the left-hand sides
-- have been renamed but the the right-hand sides have not.
-- the ...LR datatypes are parametrized by two id types,
-- one for the left and one for the right.
-- Other than during renaming, these will be the same.

type HsLocalBinds id = HsLocalBindsLR id id

data HsLocalBindsLR idL idR	-- Bindings in a 'let' expression
			       -- or a 'where' clause
  = HsValBinds (HsValBindsLR idL idR)
  | HsIPBinds  (HsIPBinds idR)
  | EmptyLocalBinds
  deriving (Data, Typeable)

type HsValBinds id = HsValBindsLR id id

data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
  = ValBindsIn             -- Before renaming RHS; idR is always RdrName
	(LHsBindsLR idL idR) [LSig idR]	-- Not dependency analysed
					-- Recursive by default

  | ValBindsOut		   -- After renaming RHS; idR can be Name or Id
	[(RecFlag, LHsBinds idL)]	-- Dependency analysed, later bindings 
                                        -- in the list may depend on earlier
                                        -- ones.
	[LSig Name]
  deriving (Data, Typeable)

type LHsBind  id = LHsBindLR  id id
type LHsBinds id = LHsBindsLR id id
type HsBind   id = HsBindLR   id id

type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
type LHsBindLR  idL idR = Located (HsBindLR idL idR)

data HsBindLR idL idR
  = -- | FunBind is used for both functions   @f x = e@
    -- and variables                          @f = \x -> e@
    --
    -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
    --
    -- Reason 2: Instance decls can only have FunBinds, which is convenient.
    --           If you change this, you'll need to change e.g. rnMethodBinds
    --
    -- But note that the form                 @f :: a->a = ...@
    -- parses as a pattern binding, just like
    --                                        @(f :: a -> a) = ... @
    FunBind {

	fun_id :: Located idL,

	fun_infix :: Bool,	-- ^ True => infix declaration

	fun_matches :: MatchGroup idR,	-- ^ The payload

	fun_co_fn :: HsWrapper,	-- ^ Coercion from the type of the MatchGroup to the type of
				-- the Id.  Example:
                                -- @
				--	f :: Int -> forall a. a -> a
				--	f x y = y
                                -- @
				-- Then the MatchGroup will have type (Int -> a' -> a')
				-- (with a free type variable a').  The coercion will take
				-- a CoreExpr of this type and convert it to a CoreExpr of
				-- type 	Int -> forall a'. a' -> a'
				-- Notice that the coercion captures the free a'.

	bind_fvs :: NameSet,	-- ^ After the renamer, this contains a superset of the
				-- Names of the other binders in this binding group that 
				-- are free in the RHS of the defn
				-- Before renaming, and after typechecking, 
				-- the field is unused; it's just an error thunk

        fun_tick :: Maybe (Int,[Id])   -- ^ This is the (optional) module-local tick number.
    }

  | PatBind {	-- The pattern is never a simple variable;
		-- That case is done by FunBind
	pat_lhs    :: LPat idL,
	pat_rhs    :: GRHSs idR,
	pat_rhs_ty :: PostTcType,	-- Type of the GRHSs
	bind_fvs   :: NameSet		-- Same as for FunBind
    }

  | VarBind {	-- Dictionary binding and suchlike 
	var_id     :: idL,	     -- All VarBinds are introduced by the type checker
	var_rhs    :: LHsExpr idR,   -- Located only for consistency
	var_inline :: Bool           -- True <=> inline this binding regardless
				     --	(used for implication constraints only)
    }

  | AbsBinds {				-- Binds abstraction; TRANSLATION
        abs_tvs     :: [TyVar],  
	abs_ev_vars :: [EvVar],	 -- Includes equality constraints

       -- AbsBinds only gets used when idL = idR after renaming,
       -- but these need to be idL's for the collect... code in HsUtil 
       -- to have the right type
	abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],	-- (tvs, poly_id, mono_id, prags)

        abs_ev_binds :: TcEvBinds,     -- Evidence bindings
	abs_binds    :: LHsBinds idL   -- Typechecked user bindings
    }

  deriving (Data, Typeable)
	-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
	-- 
	-- Creates bindings for (polymorphic, overloaded) poly_f
	-- in terms of monomorphic, non-overloaded mono_f
	--
	-- Invariants: 
	--	1. 'binds' binds mono_f
	--	2. ftvs is a subset of tvs
	--	3. ftvs includes all tyvars free in ds
	--
	-- See section 9 of static semantics paper for more details.
	-- (You can get a PhD for explaining the True Meaning
	--  of this last construct.)

placeHolderNames :: NameSet
-- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderNames = panic "placeHolderNames"

------------
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
  ppr (HsValBinds bs) = ppr bs
  ppr (HsIPBinds bs)  = ppr bs
  ppr EmptyLocalBinds = empty

instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
  ppr (ValBindsIn binds sigs)
   = pprValBindsForUser binds sigs

  ppr (ValBindsOut sccs sigs) 
    = getPprStyle $ \ sty ->
      if debugStyle sty then	-- Print with sccs showing
	vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
     else
	pprValBindsForUser (unionManyBags (map snd sccs)) sigs
   where
     ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
     pp_rec Recursive    = ptext (sLit "rec")
     pp_rec NonRecursive = ptext (sLit "nonrec")

--  *not* pprLHsBinds because we don't want braces; 'let' and
-- 'where' include a list of HsBindGroups and we don't want
-- several groups of bindings each with braces around.
-- Sort by location before printing
pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
		   => LHsBindsLR idL idR -> [LSig id2] -> SDoc
pprValBindsForUser binds sigs
  = pprDeeperList vcat (map snd (sort_by_loc decls))
  where

    decls :: [(SrcSpan, SDoc)]
    decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
    	     [(loc, ppr bind) | L loc bind <- bagToList binds]

    sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls

pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
pprLHsBinds binds 
  | isEmptyLHsBinds binds = empty
  | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace

------------
emptyLocalBinds :: HsLocalBindsLR a b
emptyLocalBinds = EmptyLocalBinds

isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True

isEmptyValBinds :: HsValBindsLR a b -> Bool
isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs

emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
emptyValBindsIn  = ValBindsIn emptyBag []
emptyValBindsOut = ValBindsOut []      []

emptyLHsBinds :: LHsBindsLR idL idR
emptyLHsBinds = emptyBag

isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
isEmptyLHsBinds = isEmptyBag

------------
plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
  = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
  = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)

getTypeSigNames :: HsValBinds a -> NameSet
-- Get the names that have a user type sig
getTypeSigNames (ValBindsIn {}) 
  = panic "getTypeSigNames"
getTypeSigNames (ValBindsOut _ sigs) 
  = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names]

instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
    ppr mbind = ppr_monobind mbind

ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc

ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
  = pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = rhs })    
  = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
	     	        fun_co_fn = wrap, 
			fun_matches = matches,
		        fun_tick = tick })
  = pprTicks empty (case tick of 
			Nothing -> empty
			Just t  -> text "-- tick id = " <> ppr t)
    $$  ifPprDebug (pprBndr LetBind (unLoc fun))
    $$  pprFunBind (unLoc fun) inf matches
    $$  ifPprDebug (ppr wrap)

ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                       , abs_exports = exports, abs_binds = val_binds
                       , abs_ev_binds = ev_binds })
  = sep [ptext (sLit "AbsBinds"),
  	 brackets (interpp'SP tyvars),
  	 brackets (interpp'SP dictvars),
  	 brackets (sep (punctuate comma (map ppr_exp exports)))]
    $$
    nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
  			-- Print type signatures
  	     $$ pprLHsBinds val_binds )
    $$
    ifPprDebug (ppr ev_binds)
  where
    ppr_exp (tvs, gbl, lcl, prags)
	= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
	  	nest 2 (pprTcSpecPrags prags)]

pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid
-- them appearing in error messages (from the desugarer); see Trac # 3263
pprTicks pp_no_debug pp_when_debug
  = getPprStyle (\ sty -> if debugStyle sty then pp_when_debug 
                                            else pp_no_debug)

data HsIPBinds id
  = IPBinds 
	[LIPBind id] 
	TcEvBinds	-- Only in typechecker output; binds 
			-- uses of the implicit parameters
  deriving (Data, Typeable)

isEmptyIPBinds :: HsIPBinds id -> Bool
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds

type LIPBind id = Located (IPBind id)

-- | Implicit parameter bindings.
data IPBind id
  = IPBind
	(IPName id)
	(LHsExpr id)
  deriving (Data, Typeable)

instance (OutputableBndr id) => Outputable (HsIPBinds id) where
  ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
                        $$ ifPprDebug (ppr ds)

instance (OutputableBndr id) => Outputable (IPBind id) where
  ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)

-- A HsWrapper is an expression with a hole in it
-- We need coercions to have concrete form so that we can zonk them

data HsWrapper
  = WpHole			-- The identity coercion

  | WpCompose HsWrapper HsWrapper	
       -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]]
       -- 
       -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
       -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)

  | WpCast Coercion		-- A cast:  [] `cast` co
				-- Guaranteed not the identity coercion

	-- Evidence abstraction and application
        -- (both dictionaries and coercions)
  | WpEvLam EvVar 		-- \d. []	the 'd' is an evidence variable
  | WpEvApp EvTerm		-- [] d		the 'd' is evidence for a constraint

	-- Type abstraction and application
  | WpTyLam TyVar 		-- \a. []	the 'a' is a type variable (not coercion var)
  | WpTyApp Type		-- [] t		the 't' is a type (not coercion)


  | WpLet TcEvBinds      	-- Non-empty (or possibly non-empty) evidence bindings,
                                -- so that the identity coercion is always exactly WpHole
  deriving (Data, Typeable)


data TcEvBinds 
  = TcEvBinds		-- Mutable evidence bindings
       EvBindsVar	-- Mutable because they are updated "later"
     	       	       	--    when an implication constraint is solved

  | EvBinds 		-- Immutable after zonking
       (Bag EvBind)

  deriving( Typeable )

data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
     -- The Unique is only for debug printing

-----------------
type EvBindMap = VarEnv EvBind

emptyEvBindMap :: EvBindMap
emptyEvBindMap = emptyVarEnv

extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)

lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
lookupEvBind = lookupVarEnv

evBindMapBinds :: EvBindMap -> Bag EvBind
evBindMapBinds = foldVarEnv consBag emptyBag

-----------------
instance Data TcEvBinds where
  -- Placeholder; we can't travers into TcEvBinds
  toConstr _   = abstractConstr "TcEvBinds"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "TcEvBinds"

-- All evidence is bound by EvBinds; no side effects
data EvBind = EvBind EvVar EvTerm

data EvTerm
  = EvId EvId                  -- Term-level variable-to-variable bindings 
                               -- (no coercion variables! they come via EvCoercion)

  | EvCoercion Coercion        -- Coercion bindings

  | EvCast EvVar Coercion      -- d |> co

  | EvDFunApp DFunId           -- Dictionary instance application
       [Type] [EvVar] 

  | EvSuperClass DictId Int    -- n'th superclass. Used for both equalities and
                               -- dictionaries, even though the former have no
			       -- selector Id.  We count up from _0_ 
			       
  deriving( Data, Typeable)

evVarTerm :: EvVar -> EvTerm
evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
            | otherwise = EvId v

emptyTcEvBinds :: TcEvBinds
emptyTcEvBinds = EvBinds emptyBag

isEmptyTcEvBinds :: TcEvBinds -> Bool
isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
 
(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
WpHole <.> c = c
c <.> WpHole = c
c1 <.> c2    = c1 `WpCompose` c2

mkWpTyApps :: [Type] -> HsWrapper
mkWpTyApps tys = mk_co_app_fn WpTyApp tys

mkWpEvApps :: [EvTerm] -> HsWrapper
mkWpEvApps args = mk_co_app_fn WpEvApp args

mkWpEvVarApps :: [EvVar] -> HsWrapper
mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)

mkWpTyLams :: [TyVar] -> HsWrapper
mkWpTyLams ids = mk_co_lam_fn WpTyLam ids

mkWpLams :: [Var] -> HsWrapper
mkWpLams ids = mk_co_lam_fn WpEvLam ids

mkWpLet :: TcEvBinds -> HsWrapper
-- This no-op is a quite a common case
mkWpLet (EvBinds b) | isEmptyBag b = WpHole
mkWpLet ev_binds                   = WpLet ev_binds

mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as

mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-- For applications, the *first* argument must
-- come *last* in the composition sequence
mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as

idHsWrapper :: HsWrapper
idHsWrapper = WpHole

isIdHsWrapper :: HsWrapper -> Bool
isIdHsWrapper WpHole = True
isIdHsWrapper _      = False

instance Outputable HsWrapper where 
  ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn

pprHsWrapper :: SDoc -> HsWrapper -> SDoc
-- In debug mode, print the wrapper
-- otherwise just print what's inside
pprHsWrapper doc wrap
  = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
  where
    help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
    -- True  <=> appears in function application position
    -- False <=> appears as body of let or lambda
    help it WpHole             = it
    help it (WpCompose f1 f2)  = help (help it f2) f1
    help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") 
                                              <+> pprParendCo co)]
    help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]
    help it (WpTyApp ty)  = no_parens  $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
    help it (WpEvLam id)  = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
    help it (WpTyLam tv)  = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
    help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]

    pp_bndr v = pprBndr LambdaBind v <> dot

    add_parens, no_parens :: SDoc -> Bool -> SDoc
    add_parens d True  = parens d
    add_parens d False = d
    no_parens d _ = d

instance Outputable TcEvBinds where
  ppr (TcEvBinds v) = ppr v
  ppr (EvBinds bs)  = ptext (sLit "EvBinds") <> braces (ppr bs)

instance Outputable EvBindsVar where
  ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)

instance Outputable EvBind where
  ppr (EvBind v e)   = ppr v <+> equals <+> ppr e

instance Outputable EvTerm where
  ppr (EvId v)        	 = ppr v
  ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
  ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co
  ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]

type LSig name = Located (Sig name)

data Sig name	-- Signatures and pragmas
  = 	-- An ordinary type signature
	-- f :: Num a => a -> a
    TypeSig [Located name] (LHsType name)

        -- A type signature for a default method inside a class
        -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
  | GenericSig [Located name] (LHsType name)

	-- A type signature in generated code, notably the code
	-- generated for record selectors.  We simply record
	-- the desired Id itself, replete with its name, type
	-- and IdDetails.  Otherwise it's just like a type 
	-- signature: there should be an accompanying binding
  | IdSig Id

	-- An ordinary fixity declaration
	--	infixl *** 8
  | FixSig (FixitySig name)

	-- An inline pragma
	-- {#- INLINE f #-}
  | InlineSig	(Located name)	-- Function name
		InlinePragma	-- Never defaultInlinePragma

	-- A specialisation pragma
	-- {-# SPECIALISE f :: Int -> Int #-}
  | SpecSig 	(Located name)	-- Specialise a function or datatype ...
		(LHsType name)	-- ... to these types
		InlinePragma    -- The pragma on SPECIALISE_INLINE form
				-- If it's just defaultInlinePragma, then we said
				--    SPECIALISE, not SPECIALISE_INLINE

        -- A specialisation pragma for instance declarations only
        -- {-# SPECIALISE instance Eq [Int] #-}
  | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the 
                                -- current instance decl
  deriving (Data, Typeable)


type LFixitySig name = Located (FixitySig name)
data FixitySig name = FixitySig (Located name) Fixity 
  deriving (Data, Typeable)

-- TsSpecPrags conveys pragmas from the type checker to the desugarer
data TcSpecPrags 
  = IsDefaultMethod	-- Super-specialised: a default method should 
    			-- be macro-expanded at every call site
  | SpecPrags [LTcSpecPrag]
  deriving (Data, Typeable)

type LTcSpecPrag = Located TcSpecPrag

data TcSpecPrag 
  = SpecPrag   
        Id		-- The Id to be specialised
	HsWrapper	-- An wrapper, that specialises the polymorphic function
	InlinePragma 	-- Inlining spec for the specialised function
  deriving (Data, Typeable)

noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []

hasSpecPrags :: TcSpecPrags -> Bool
hasSpecPrags (SpecPrags ps) = not (null ps)
hasSpecPrags IsDefaultMethod = False

isDefaultMethod :: TcSpecPrags -> Bool
isDefaultMethod IsDefaultMethod = True
isDefaultMethod (SpecPrags {})  = False

okBindSig :: Sig a -> Bool
okBindSig _ = True

okHsBootSig :: Sig a -> Bool
okHsBootSig (TypeSig  _ _)    = True
okHsBootSig (GenericSig  _ _) = False
okHsBootSig (FixSig _) 	      = True
okHsBootSig _                 = False

okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False
okClsDclSig _               = True        -- All others OK

okInstDclSig :: Sig a -> Bool
okInstDclSig (TypeSig _ _)    = False
okInstDclSig (GenericSig _ _) = False
okInstDclSig (FixSig _)       = False
okInstDclSig _ 	              = True

isFixityLSig :: LSig name -> Bool
isFixityLSig (L _ (FixSig {})) = True
isFixityLSig _	               = False

isVanillaLSig :: LSig name -> Bool	 -- User type signatures
-- A badly-named function, but it's part of the GHCi (used
-- by Haddock) so I don't want to change it gratuitously.
isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig _                 = False

isTypeLSig :: LSig name -> Bool	 -- Type signatures
isTypeLSig (L _(TypeSig {}))    = True
isTypeLSig (L _(GenericSig {})) = True
isTypeLSig (L _(IdSig {}))      = True
isTypeLSig _                    = False

isSpecLSig :: LSig name -> Bool
isSpecLSig (L _(SpecSig {})) = True
isSpecLSig _                 = False

isSpecInstLSig :: LSig name -> Bool
isSpecInstLSig (L _ (SpecInstSig {})) = True
isSpecInstLSig _                      = False

isPragLSig :: LSig name -> Bool
	-- Identifies pragmas 
isPragLSig (L _ (SpecSig {}))   = True
isPragLSig (L _ (InlineSig {})) = True
isPragLSig _                    = False

isInlineLSig :: LSig name -> Bool
	-- Identifies inline pragmas 
isInlineLSig (L _ (InlineSig {})) = True
isInlineLSig _                    = False

hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) 		= ptext (sLit "type signature")
hsSigDoc (GenericSig {})	= ptext (sLit "default type signature")
hsSigDoc (IdSig {}) 		= ptext (sLit "id signature")
hsSigDoc (SpecSig {})	 	= ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
hsSigDoc (SpecInstSig {})	= ptext (sLit "SPECIALISE instance pragma")
hsSigDoc (FixSig {}) 		= ptext (sLit "fixity declaration")

eqHsSig :: Eq a => LSig a -> LSig a -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
eqHsSig (L _ (IdSig n1))         	(L _ (IdSig n2))                = n1 == n2
eqHsSig (L _ (TypeSig ns1 _))         	(L _ (TypeSig ns2 _))           = map unLoc ns1 == map unLoc ns2
eqHsSig (L _ (GenericSig ns1 _))        (L _ (GenericSig ns2 _))        = map unLoc ns1 == map unLoc ns2
eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
 	-- For specialisations, we don't have equality over
	-- HsType, so it's not convenient to spot duplicate 
	-- specialisations here.  Check for this later, when we're in Type land
eqHsSig _other1 _other2 = False

instance (OutputableBndr name) => Outputable (Sig name) where
    ppr sig = ppr_sig sig

ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig vars ty)	  = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (GenericSig vars ty)	  = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (IdSig id)	          = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig fix_sig) 	  = ppr fix_sig
ppr_sig (SpecSig var ty inl) 	  = pragBrackets (pprSpec var (ppr ty) inl)
ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
ppr_sig (SpecInstSig ty) 	  = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)

instance Outputable name => Outputable (FixitySig name) where
  ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]

pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") 

pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc
pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
  where
    pprvars = hsep $ punctuate comma (map ppr vars)

pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
  where
    pp_inl | isDefaultInlinePragma inl = empty
           | otherwise = ppr inl

pprTcSpecPrags :: TcSpecPrags -> SDoc
pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)

instance Outputable TcSpecPrag where
  ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl