2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
7 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
10 {-# OPTIONS -fno-warn-incomplete-patterns #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 {-# LANGUAGE DeriveDataTypeable #-}
20 import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
21 MatchGroup, pprFunBind,
23 import {-# SOURCE #-} HsPat ( LPat )
41 import Data.IORef( IORef )
42 import Data.Data hiding ( Fixity )
45 %************************************************************************
47 \subsection{Bindings: @BindGroup@}
49 %************************************************************************
51 Global bindings (where clauses)
54 -- During renaming, we need bindings where the left-hand sides
55 -- have been renamed but the the right-hand sides have not.
56 -- the ...LR datatypes are parametrized by two id types,
57 -- one for the left and one for the right.
58 -- Other than during renaming, these will be the same.
60 type HsLocalBinds id = HsLocalBindsLR id id
62 data HsLocalBindsLR idL idR -- Bindings in a 'let' expression
63 -- or a 'where' clause
64 = HsValBinds (HsValBindsLR idL idR)
65 | HsIPBinds (HsIPBinds idR)
67 deriving (Data, Typeable)
69 type HsValBinds id = HsValBindsLR id id
71 data HsValBindsLR idL idR -- Value bindings (not implicit parameters)
72 = ValBindsIn -- Before renaming
73 (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
74 -- Recursive by default
76 | ValBindsOut -- After renaming
77 [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
78 -- in the list may depend on earlier
81 deriving (Data, Typeable)
83 type LHsBinds id = Bag (LHsBind id)
84 type LHsBind id = Located (HsBind id)
85 type HsBind id = HsBindLR id id
87 type LHsBindLR idL idR = Located (HsBindLR idL idR)
88 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
91 = -- | FunBind is used for both functions @f x = e@
92 -- and variables @f = \x -> e@
94 -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
96 -- Reason 2: Instance decls can only have FunBinds, which is convenient.
97 -- If you change this, you'll need to change e.g. rnMethodBinds
99 -- But note that the form @f :: a->a = ...@
100 -- parses as a pattern binding, just like
101 -- @(f :: a -> a) = ... @
104 fun_id :: Located idL,
106 fun_infix :: Bool, -- ^ True => infix declaration
108 fun_matches :: MatchGroup idR, -- ^ The payload
110 fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
113 -- f :: Int -> forall a. a -> a
116 -- Then the MatchGroup will have type (Int -> a' -> a')
117 -- (with a free type variable a'). The coercion will take
118 -- a CoreExpr of this type and convert it to a CoreExpr of
119 -- type Int -> forall a'. a' -> a'
120 -- Notice that the coercion captures the free a'.
122 bind_fvs :: NameSet, -- ^ After the renamer, this contains a superset of the
123 -- Names of the other binders in this binding group that
124 -- are free in the RHS of the defn
125 -- Before renaming, and after typechecking,
126 -- the field is unused; it's just an error thunk
128 fun_tick :: Maybe (Int,[Id]) -- ^ This is the (optional) module-local tick number.
131 | PatBind { -- The pattern is never a simple variable;
132 -- That case is done by FunBind
134 pat_rhs :: GRHSs idR,
135 pat_rhs_ty :: PostTcType, -- Type of the GRHSs
136 bind_fvs :: NameSet -- Same as for FunBind
139 | VarBind { -- Dictionary binding and suchlike
140 var_id :: idL, -- All VarBinds are introduced by the type checker
141 var_rhs :: LHsExpr idR, -- Located only for consistency
142 var_inline :: Bool -- True <=> inline this binding regardless
143 -- (used for implication constraints only)
146 | AbsBinds { -- Binds abstraction; TRANSLATION
148 abs_ev_vars :: [EvVar], -- Includes equality constraints
150 -- AbsBinds only gets used when idL = idR after renaming,
151 -- but these need to be idL's for the collect... code in HsUtil to have
153 abs_exports :: [([TyVar], idL, idL, TcSpecPrags)], -- (tvs, poly_id, mono_id, prags)
155 abs_ev_binds :: TcEvBinds, -- Evidence bindings
156 abs_binds :: LHsBinds idL -- Typechecked user bindings
158 deriving (Data, Typeable)
159 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
161 -- Creates bindings for (polymorphic, overloaded) poly_f
162 -- in terms of monomorphic, non-overloaded mono_f
165 -- 1. 'binds' binds mono_f
166 -- 2. ftvs is a subset of tvs
167 -- 3. ftvs includes all tyvars free in ds
169 -- See section 9 of static semantics paper for more details.
170 -- (You can get a PhD for explaining the True Meaning
171 -- of this last construct.)
173 placeHolderNames :: NameSet
174 -- Used for the NameSet in FunBind and PatBind prior to the renamer
175 placeHolderNames = panic "placeHolderNames"
178 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
179 ppr (HsValBinds bs) = ppr bs
180 ppr (HsIPBinds bs) = ppr bs
181 ppr EmptyLocalBinds = empty
183 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
184 ppr (ValBindsIn binds sigs)
185 = pprValBindsForUser binds sigs
187 ppr (ValBindsOut sccs sigs)
188 = getPprStyle $ \ sty ->
189 if debugStyle sty then -- Print with sccs showing
190 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
192 pprValBindsForUser (unionManyBags (map snd sccs)) sigs
194 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
195 pp_rec Recursive = ptext (sLit "rec")
196 pp_rec NonRecursive = ptext (sLit "nonrec")
198 -- *not* pprLHsBinds because we don't want braces; 'let' and
199 -- 'where' include a list of HsBindGroups and we don't want
200 -- several groups of bindings each with braces around.
201 -- Sort by location before printing
202 pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
203 => LHsBindsLR idL idR -> [LSig id2] -> SDoc
204 pprValBindsForUser binds sigs
205 = pprDeeperList vcat (map snd (sort_by_loc decls))
208 decls :: [(SrcSpan, SDoc)]
209 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
210 [(loc, ppr bind) | L loc bind <- bagToList binds]
212 sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
214 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
216 | isEmptyLHsBinds binds = empty
217 | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
220 emptyLocalBinds :: HsLocalBindsLR a b
221 emptyLocalBinds = EmptyLocalBinds
223 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
224 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
225 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
226 isEmptyLocalBinds EmptyLocalBinds = True
228 isEmptyValBinds :: HsValBindsLR a b -> Bool
229 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
230 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
232 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
233 emptyValBindsIn = ValBindsIn emptyBag []
234 emptyValBindsOut = ValBindsOut [] []
236 emptyLHsBinds :: LHsBindsLR idL idR
237 emptyLHsBinds = emptyBag
239 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
240 isEmptyLHsBinds = isEmptyBag
243 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
244 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
245 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
246 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
247 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
249 getTypeSigNames :: HsValBinds a -> NameSet
250 -- Get the names that have a user type sig
251 getTypeSigNames (ValBindsIn {})
252 = panic "getTypeSigNames"
253 getTypeSigNames (ValBindsOut _ sigs)
254 = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs]
266 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
269 gp = ...same again, with gm instead of fm
271 This is a pretty bad translation, because it duplicates all the bindings.
272 So the desugarer tries to do a better job:
274 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
278 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
282 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
283 ppr mbind = ppr_monobind mbind
285 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
287 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
288 = pprPatBind pat grhss
289 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
290 = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
291 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
293 fun_matches = matches,
295 = pprTicks empty (case tick of
297 Just t -> text "-- tick id = " <> ppr t)
298 $$ ifPprDebug (pprBndr LetBind (unLoc fun))
299 $$ pprFunBind (unLoc fun) inf matches
300 $$ ifPprDebug (ppr wrap)
302 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
303 , abs_exports = exports, abs_binds = val_binds
304 , abs_ev_binds = ev_binds })
305 = sep [ptext (sLit "AbsBinds"),
306 brackets (interpp'SP tyvars),
307 brackets (interpp'SP dictvars),
308 brackets (sep (punctuate comma (map ppr_exp exports)))]
310 nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
311 -- Print type signatures
312 $$ pprLHsBinds val_binds )
314 ifPprDebug (ppr ev_binds)
316 ppr_exp (tvs, gbl, lcl, prags)
317 = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
318 nest 2 (pprTcSpecPrags prags)]
323 pprTicks :: SDoc -> SDoc -> SDoc
324 -- Print stuff about ticks only when -dppr-debug is on, to avoid
325 -- them appearing in error messages (from the desugarer); see Trac # 3263
326 pprTicks pp_no_debug pp_when_debug
327 = getPprStyle (\ sty -> if debugStyle sty then pp_when_debug
331 %************************************************************************
333 Implicit parameter bindings
335 %************************************************************************
341 TcEvBinds -- Only in typechecker output; binds
342 -- uses of the implicit parameters
343 deriving (Data, Typeable)
345 isEmptyIPBinds :: HsIPBinds id -> Bool
346 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
348 type LIPBind id = Located (IPBind id)
350 -- | Implicit parameter bindings.
355 deriving (Data, Typeable)
357 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
358 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
359 $$ ifPprDebug (ppr ds)
361 instance (OutputableBndr id) => Outputable (IPBind id) where
362 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
366 %************************************************************************
368 \subsection{Coercion functions}
370 %************************************************************************
373 -- A HsWrapper is an expression with a hole in it
374 -- We need coercions to have concrete form so that we can zonk them
377 = WpHole -- The identity coercion
379 | WpCompose HsWrapper HsWrapper
380 -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]]
382 -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. [])
383 -- But ([] a) `WpCompose` ([] b) = ([] b a)
385 | WpCast Coercion -- A cast: [] `cast` co
386 -- Guaranteed not the identity coercion
388 -- Evidence abstraction and application
389 -- (both dictionaries and coercions)
390 | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable
391 | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint
393 -- Type abstraction and application
394 | WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
395 | WpTyApp Type -- [] t the 't' is a type (not coercion)
398 | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
399 -- so that the identity coercion is always exactly WpHole
400 deriving (Data, Typeable)
404 = TcEvBinds -- Mutable evidence bindings
405 EvBindsVar -- Mutable because they are updated "later"
406 -- when an implication constraint is solved
408 | EvBinds -- Immutable after zonking
413 data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
414 -- The Unique is only for debug printing
417 type EvBindMap = VarEnv EvBind
419 emptyEvBindMap :: EvBindMap
420 emptyEvBindMap = emptyVarEnv
422 extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
423 extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
425 lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
426 lookupEvBind = lookupVarEnv
428 evBindMapBinds :: EvBindMap -> Bag EvBind
429 evBindMapBinds = foldVarEnv consBag emptyBag
432 instance Data TcEvBinds where
433 -- Placeholder; we can't travers into TcEvBinds
434 toConstr _ = abstractConstr "TcEvBinds"
435 gunfold _ _ = error "gunfold"
436 dataTypeOf _ = mkNoRepType "TcEvBinds"
438 -- All evidence is bound by EvBinds; no side effects
439 data EvBind = EvBind EvVar EvTerm
442 = EvId EvId -- Term-level variable-to-variable bindings
443 -- (no coercion variables! they come via EvCoercion)
445 | EvCoercion Coercion -- Coercion bindings
447 | EvCast EvVar Coercion -- d |> co
449 | EvDFunApp DFunId -- Dictionary instance application
451 [EvVar] -- The dependencies, which is generally a bigger list than
452 -- the arguments of the dfun.
453 -- See Note [Dependencies in self dictionaries] in TcSimplify
455 | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
456 -- dictionaries, even though the former have no
457 -- selector Id. We count up from _0_
459 deriving( Data, Typeable)
461 evVarTerm :: EvVar -> EvTerm
462 evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
466 Note [EvBinds/EvTerm]
467 ~~~~~~~~~~~~~~~~~~~~~
468 How evidence is created and updated. Bindings for dictionaries,
469 and coercions and implicit parameters are carried around in TcEvBinds
470 which during constraint generation and simplification is always of the
471 form (TcEvBinds ref). After constraint simplification is finished it
472 will be transformed to t an (EvBinds ev_bag).
474 Evidence for coercions *SHOULD* be filled in using the TcEvBinds
475 However, all EvVars that correspond to *wanted* coercion terms in
476 an EvBind must be mutable variables so that they can be readily
477 inlined (by zonking) after constraint simplification is finished.
479 Conclusion: a new wanted coercion variable should be made mutable.
480 [Notice though that evidence variables that bind coercion terms
481 from super classes will be "given" and hence rigid]
485 emptyTcEvBinds :: TcEvBinds
486 emptyTcEvBinds = EvBinds emptyBag
488 isEmptyTcEvBinds :: TcEvBinds -> Bool
489 isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
490 isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
492 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
495 c1 <.> c2 = c1 `WpCompose` c2
497 mkWpTyApps :: [Type] -> HsWrapper
498 mkWpTyApps tys = mk_co_app_fn WpTyApp tys
500 mkWpEvApps :: [EvTerm] -> HsWrapper
501 mkWpEvApps args = mk_co_app_fn WpEvApp args
503 mkWpEvVarApps :: [EvVar] -> HsWrapper
504 mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
506 mkWpTyLams :: [TyVar] -> HsWrapper
507 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
509 mkWpLams :: [Var] -> HsWrapper
510 mkWpLams ids = mk_co_lam_fn WpEvLam ids
512 mkWpLet :: TcEvBinds -> HsWrapper
513 -- This no-op is a quite a common case
514 mkWpLet (EvBinds b) | isEmptyBag b = WpHole
515 mkWpLet ev_binds = WpLet ev_binds
517 mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
518 mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
520 mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
521 -- For applications, the *first* argument must
522 -- come *last* in the composition sequence
523 mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
525 idHsWrapper :: HsWrapper
528 isIdHsWrapper :: HsWrapper -> Bool
529 isIdHsWrapper WpHole = True
530 isIdHsWrapper _ = False
536 instance Outputable HsWrapper where
537 ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
539 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
540 -- In debug mode, print the wrapper
541 -- otherwise just print what's inside
542 pprHsWrapper doc wrap
543 = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
545 help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
546 -- True <=> appears in function application position
547 -- False <=> appears as body of let or lambda
549 help it (WpCompose f1 f2) = help (help it f2) f1
550 help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
551 <+> pprParendType co)]
552 help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
553 help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
554 help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
555 help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
556 help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
558 pp_bndr v = pprBndr LambdaBind v <> dot
560 add_parens, no_parens :: SDoc -> Bool -> SDoc
561 add_parens d True = parens d
562 add_parens d False = d
565 instance Outputable TcEvBinds where
566 ppr (TcEvBinds v) = ppr v
567 ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (ppr bs)
569 instance Outputable EvBindsVar where
570 ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
572 instance Outputable EvBind where
573 ppr (EvBind v e) = ppr v <+> equals <+> ppr e
575 instance Outputable EvTerm where
577 ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
578 ppr (EvCoercion co) = ppr co
579 ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
580 ppr (EvDFunApp df tys ts deps) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts, ppr deps ]
583 %************************************************************************
585 \subsection{@Sig@: type signatures and value-modifying user pragmas}
587 %************************************************************************
589 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
590 ``specialise this function to these four types...'') in with type
591 signatures. Then all the machinery to move them into place, etc.,
595 type LSig name = Located (Sig name)
597 data Sig name -- Signatures and pragmas
598 = -- An ordinary type signature
599 -- f :: Num a => a -> a
600 TypeSig (Located name) (LHsType name)
602 -- A type signature in generated code, notably the code
603 -- generated for record selectors. We simply record
604 -- the desired Id itself, replete with its name, type
605 -- and IdDetails. Otherwise it's just like a type
606 -- signature: there should be an accompanying binding
609 -- An ordinary fixity declaration
611 | FixSig (FixitySig name)
615 | InlineSig (Located name) -- Function name
616 InlinePragma -- Never defaultInlinePragma
618 -- A specialisation pragma
619 -- {-# SPECIALISE f :: Int -> Int #-}
620 | SpecSig (Located name) -- Specialise a function or datatype ...
621 (LHsType name) -- ... to these types
622 InlinePragma -- The pragma on SPECIALISE_INLINE form
623 -- If it's just defaultInlinePragma, then we said
624 -- SPECIALISE, not SPECIALISE_INLINE
626 -- A specialisation pragma for instance declarations only
627 -- {-# SPECIALISE instance Eq [Int] #-}
628 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
629 -- current instance decl
630 deriving (Data, Typeable)
633 type LFixitySig name = Located (FixitySig name)
634 data FixitySig name = FixitySig (Located name) Fixity
635 deriving (Data, Typeable)
637 -- TsSpecPrags conveys pragmas from the type checker to the desugarer
639 = IsDefaultMethod -- Super-specialised: a default method should
640 -- be macro-expanded at every call site
641 | SpecPrags [LTcSpecPrag]
642 deriving (Data, Typeable)
644 type LTcSpecPrag = Located TcSpecPrag
648 Id -- The Id to be specialised
649 HsWrapper -- An wrapper, that specialises the polymorphic function
650 InlinePragma -- Inlining spec for the specialised function
651 deriving (Data, Typeable)
653 noSpecPrags :: TcSpecPrags
654 noSpecPrags = SpecPrags []
656 hasSpecPrags :: TcSpecPrags -> Bool
657 hasSpecPrags (SpecPrags ps) = not (null ps)
658 hasSpecPrags IsDefaultMethod = False
660 isDefaultMethod :: TcSpecPrags -> Bool
661 isDefaultMethod IsDefaultMethod = True
662 isDefaultMethod (SpecPrags {}) = False
667 okBindSig :: Sig a -> Bool
670 okHsBootSig :: Sig a -> Bool
671 okHsBootSig (TypeSig _ _) = True
672 okHsBootSig (FixSig _) = True
673 okHsBootSig _ = False
675 okClsDclSig :: Sig a -> Bool
676 okClsDclSig (SpecInstSig _) = False
677 okClsDclSig _ = True -- All others OK
679 okInstDclSig :: Sig a -> Bool
680 okInstDclSig (TypeSig _ _) = False
681 okInstDclSig (FixSig _) = False
682 okInstDclSig _ = True
684 sigForThisGroup :: NameSet -> LSig Name -> Bool
685 sigForThisGroup ns sig
686 = case sigName sig of
688 Just n -> n `elemNameSet` ns
690 sigName :: LSig name -> Maybe name
691 sigName (L _ sig) = sigNameNoLoc sig
693 sigNameNoLoc :: Sig name -> Maybe name
694 sigNameNoLoc (TypeSig n _) = Just (unLoc n)
695 sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)
696 sigNameNoLoc (InlineSig n _) = Just (unLoc n)
697 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
698 sigNameNoLoc _ = Nothing
700 isFixityLSig :: LSig name -> Bool
701 isFixityLSig (L _ (FixSig {})) = True
702 isFixityLSig _ = False
704 isVanillaLSig :: LSig name -> Bool -- User type signatures
705 -- A badly-named function, but it's part of the GHCi (used
706 -- by Haddock) so I don't want to change it gratuitously.
707 isVanillaLSig (L _(TypeSig {})) = True
708 isVanillaLSig _ = False
710 isTypeLSig :: LSig name -> Bool -- Type signatures
711 isTypeLSig (L _(TypeSig {})) = True
712 isTypeLSig (L _(IdSig {})) = True
715 isSpecLSig :: LSig name -> Bool
716 isSpecLSig (L _(SpecSig {})) = True
719 isSpecInstLSig :: LSig name -> Bool
720 isSpecInstLSig (L _ (SpecInstSig {})) = True
721 isSpecInstLSig _ = False
723 isPragLSig :: LSig name -> Bool
724 -- Identifies pragmas
725 isPragLSig (L _ (SpecSig {})) = True
726 isPragLSig (L _ (InlineSig {})) = True
729 isInlineLSig :: LSig name -> Bool
730 -- Identifies inline pragmas
731 isInlineLSig (L _ (InlineSig {})) = True
732 isInlineLSig _ = False
734 hsSigDoc :: Sig name -> SDoc
735 hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
736 hsSigDoc (IdSig {}) = ptext (sLit "id signature")
737 hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
738 hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
739 hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma")
740 hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration")
743 Signature equality is used when checking for duplicate signatures
746 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
747 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
748 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
749 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
750 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
751 -- For specialisations, we don't have equality over
752 -- HsType, so it's not convenient to spot duplicate
753 -- specialisations here. Check for this later, when we're in Type land
754 eqHsSig _other1 _other2 = False
758 instance (OutputableBndr name) => Outputable (Sig name) where
759 ppr sig = ppr_sig sig
761 ppr_sig :: OutputableBndr name => Sig name -> SDoc
762 ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
763 ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
764 ppr_sig (FixSig fix_sig) = ppr fix_sig
765 ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
766 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
767 ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
769 instance Outputable name => Outputable (FixitySig name) where
770 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
772 pragBrackets :: SDoc -> SDoc
773 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
775 pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
776 pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
778 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
779 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
781 pp_inl | isDefaultInlinePragma inl = empty
782 | otherwise = ppr inl
784 pprTcSpecPrags :: TcSpecPrags -> SDoc
785 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
786 pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
788 instance Outputable TcSpecPrag where
789 ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl