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 RHS; idR is always RdrName
73 (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
74 -- Recursive by default
76 | ValBindsOut -- After renaming RHS; idR can be Name or Id
77 [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
78 -- in the list may depend on earlier
81 deriving (Data, Typeable)
83 type LHsBind id = LHsBindLR id id
84 type LHsBinds id = LHsBindsLR id id
85 type HsBind id = HsBindLR id id
87 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
88 type LHsBindLR idL idR = Located (HsBindLR 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
159 deriving (Data, Typeable)
160 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
162 -- Creates bindings for (polymorphic, overloaded) poly_f
163 -- in terms of monomorphic, non-overloaded mono_f
166 -- 1. 'binds' binds mono_f
167 -- 2. ftvs is a subset of tvs
168 -- 3. ftvs includes all tyvars free in ds
170 -- See section 9 of static semantics paper for more details.
171 -- (You can get a PhD for explaining the True Meaning
172 -- of this last construct.)
174 placeHolderNames :: NameSet
175 -- Used for the NameSet in FunBind and PatBind prior to the renamer
176 placeHolderNames = panic "placeHolderNames"
179 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
180 ppr (HsValBinds bs) = ppr bs
181 ppr (HsIPBinds bs) = ppr bs
182 ppr EmptyLocalBinds = empty
184 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
185 ppr (ValBindsIn binds sigs)
186 = pprValBindsForUser binds sigs
188 ppr (ValBindsOut sccs sigs)
189 = getPprStyle $ \ sty ->
190 if debugStyle sty then -- Print with sccs showing
191 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
193 pprValBindsForUser (unionManyBags (map snd sccs)) sigs
195 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
196 pp_rec Recursive = ptext (sLit "rec")
197 pp_rec NonRecursive = ptext (sLit "nonrec")
199 -- *not* pprLHsBinds because we don't want braces; 'let' and
200 -- 'where' include a list of HsBindGroups and we don't want
201 -- several groups of bindings each with braces around.
202 -- Sort by location before printing
203 pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
204 => LHsBindsLR idL idR -> [LSig id2] -> SDoc
205 pprValBindsForUser binds sigs
206 = pprDeeperList vcat (map snd (sort_by_loc decls))
209 decls :: [(SrcSpan, SDoc)]
210 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
211 [(loc, ppr bind) | L loc bind <- bagToList binds]
213 sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
215 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
217 | isEmptyLHsBinds binds = empty
218 | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
221 emptyLocalBinds :: HsLocalBindsLR a b
222 emptyLocalBinds = EmptyLocalBinds
224 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
225 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
226 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
227 isEmptyLocalBinds EmptyLocalBinds = True
229 isEmptyValBinds :: HsValBindsLR a b -> Bool
230 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
231 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
233 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
234 emptyValBindsIn = ValBindsIn emptyBag []
235 emptyValBindsOut = ValBindsOut [] []
237 emptyLHsBinds :: LHsBindsLR idL idR
238 emptyLHsBinds = emptyBag
240 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
241 isEmptyLHsBinds = isEmptyBag
244 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
245 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
246 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
247 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
248 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
250 getTypeSigNames :: HsValBinds a -> NameSet
251 -- Get the names that have a user type sig
252 getTypeSigNames (ValBindsIn {})
253 = panic "getTypeSigNames"
254 getTypeSigNames (ValBindsOut _ sigs)
255 = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs]
267 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
270 gp = ...same again, with gm instead of fm
272 This is a pretty bad translation, because it duplicates all the bindings.
273 So the desugarer tries to do a better job:
275 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
279 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
283 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
284 ppr mbind = ppr_monobind mbind
286 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
288 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
289 = pprPatBind pat grhss
290 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
291 = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
292 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
294 fun_matches = matches,
296 = pprTicks empty (case tick of
298 Just t -> text "-- tick id = " <> ppr t)
299 $$ ifPprDebug (pprBndr LetBind (unLoc fun))
300 $$ pprFunBind (unLoc fun) inf matches
301 $$ ifPprDebug (ppr wrap)
303 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
304 , abs_exports = exports, abs_binds = val_binds
305 , abs_ev_binds = ev_binds })
306 = sep [ptext (sLit "AbsBinds"),
307 brackets (interpp'SP tyvars),
308 brackets (interpp'SP dictvars),
309 brackets (sep (punctuate comma (map ppr_exp exports)))]
311 nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
312 -- Print type signatures
313 $$ pprLHsBinds val_binds )
315 ifPprDebug (ppr ev_binds)
317 ppr_exp (tvs, gbl, lcl, prags)
318 = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
319 nest 2 (pprTcSpecPrags prags)]
324 pprTicks :: SDoc -> SDoc -> SDoc
325 -- Print stuff about ticks only when -dppr-debug is on, to avoid
326 -- them appearing in error messages (from the desugarer); see Trac # 3263
327 pprTicks pp_no_debug pp_when_debug
328 = getPprStyle (\ sty -> if debugStyle sty then pp_when_debug
332 %************************************************************************
334 Implicit parameter bindings
336 %************************************************************************
342 TcEvBinds -- Only in typechecker output; binds
343 -- uses of the implicit parameters
344 deriving (Data, Typeable)
346 isEmptyIPBinds :: HsIPBinds id -> Bool
347 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
349 type LIPBind id = Located (IPBind id)
351 -- | Implicit parameter bindings.
356 deriving (Data, Typeable)
358 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
359 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
360 $$ ifPprDebug (ppr ds)
362 instance (OutputableBndr id) => Outputable (IPBind id) where
363 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
367 %************************************************************************
369 \subsection{Coercion functions}
371 %************************************************************************
374 -- A HsWrapper is an expression with a hole in it
375 -- We need coercions to have concrete form so that we can zonk them
378 = WpHole -- The identity coercion
380 | WpCompose HsWrapper HsWrapper
381 -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]]
383 -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. [])
384 -- But ([] a) `WpCompose` ([] b) = ([] b a)
386 | WpCast Coercion -- A cast: [] `cast` co
387 -- Guaranteed not the identity coercion
389 -- Evidence abstraction and application
390 -- (both dictionaries and coercions)
391 | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable
392 | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint
394 -- Type abstraction and application
395 | WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
396 | WpTyApp Type -- [] t the 't' is a type (not coercion)
399 | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
400 -- so that the identity coercion is always exactly WpHole
401 deriving (Data, Typeable)
405 = TcEvBinds -- Mutable evidence bindings
406 EvBindsVar -- Mutable because they are updated "later"
407 -- when an implication constraint is solved
409 | EvBinds -- Immutable after zonking
414 data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
415 -- The Unique is only for debug printing
418 type EvBindMap = VarEnv EvBind
420 emptyEvBindMap :: EvBindMap
421 emptyEvBindMap = emptyVarEnv
423 extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
424 extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
426 lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
427 lookupEvBind = lookupVarEnv
429 evBindMapBinds :: EvBindMap -> Bag EvBind
430 evBindMapBinds = foldVarEnv consBag emptyBag
433 instance Data TcEvBinds where
434 -- Placeholder; we can't travers into TcEvBinds
435 toConstr _ = abstractConstr "TcEvBinds"
436 gunfold _ _ = error "gunfold"
437 dataTypeOf _ = mkNoRepType "TcEvBinds"
439 -- All evidence is bound by EvBinds; no side effects
440 data EvBind = EvBind EvVar EvTerm
443 = EvId EvId -- Term-level variable-to-variable bindings
444 -- (no coercion variables! they come via EvCoercion)
446 | EvCoercion Coercion -- Coercion bindings
448 | EvCast EvVar Coercion -- d |> co
450 | EvDFunApp DFunId -- Dictionary instance application
453 | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
454 -- dictionaries, even though the former have no
455 -- selector Id. We count up from _0_
457 deriving( Data, Typeable)
459 evVarTerm :: EvVar -> EvTerm
460 evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
464 Note [EvBinds/EvTerm]
465 ~~~~~~~~~~~~~~~~~~~~~
466 How evidence is created and updated. Bindings for dictionaries,
467 and coercions and implicit parameters are carried around in TcEvBinds
468 which during constraint generation and simplification is always of the
469 form (TcEvBinds ref). After constraint simplification is finished it
470 will be transformed to t an (EvBinds ev_bag).
472 Evidence for coercions *SHOULD* be filled in using the TcEvBinds
473 However, all EvVars that correspond to *wanted* coercion terms in
474 an EvBind must be mutable variables so that they can be readily
475 inlined (by zonking) after constraint simplification is finished.
477 Conclusion: a new wanted coercion variable should be made mutable.
478 [Notice though that evidence variables that bind coercion terms
479 from super classes will be "given" and hence rigid]
483 emptyTcEvBinds :: TcEvBinds
484 emptyTcEvBinds = EvBinds emptyBag
486 isEmptyTcEvBinds :: TcEvBinds -> Bool
487 isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
488 isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
490 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
493 c1 <.> c2 = c1 `WpCompose` c2
495 mkWpTyApps :: [Type] -> HsWrapper
496 mkWpTyApps tys = mk_co_app_fn WpTyApp tys
498 mkWpEvApps :: [EvTerm] -> HsWrapper
499 mkWpEvApps args = mk_co_app_fn WpEvApp args
501 mkWpEvVarApps :: [EvVar] -> HsWrapper
502 mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
504 mkWpTyLams :: [TyVar] -> HsWrapper
505 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
507 mkWpLams :: [Var] -> HsWrapper
508 mkWpLams ids = mk_co_lam_fn WpEvLam ids
510 mkWpLet :: TcEvBinds -> HsWrapper
511 -- This no-op is a quite a common case
512 mkWpLet (EvBinds b) | isEmptyBag b = WpHole
513 mkWpLet ev_binds = WpLet ev_binds
515 mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
516 mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
518 mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
519 -- For applications, the *first* argument must
520 -- come *last* in the composition sequence
521 mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
523 idHsWrapper :: HsWrapper
526 isIdHsWrapper :: HsWrapper -> Bool
527 isIdHsWrapper WpHole = True
528 isIdHsWrapper _ = False
534 instance Outputable HsWrapper where
535 ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
537 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
538 -- In debug mode, print the wrapper
539 -- otherwise just print what's inside
540 pprHsWrapper doc wrap
541 = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
543 help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
544 -- True <=> appears in function application position
545 -- False <=> appears as body of let or lambda
547 help it (WpCompose f1 f2) = help (help it f2) f1
548 help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
550 help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
551 help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
552 help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
553 help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
554 help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
556 pp_bndr v = pprBndr LambdaBind v <> dot
558 add_parens, no_parens :: SDoc -> Bool -> SDoc
559 add_parens d True = parens d
560 add_parens d False = d
563 instance Outputable TcEvBinds where
564 ppr (TcEvBinds v) = ppr v
565 ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (ppr bs)
567 instance Outputable EvBindsVar where
568 ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
570 instance Outputable EvBind where
571 ppr (EvBind v e) = ppr v <+> equals <+> ppr e
573 instance Outputable EvTerm where
575 ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
576 ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
577 ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
578 ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
581 %************************************************************************
583 \subsection{@Sig@: type signatures and value-modifying user pragmas}
585 %************************************************************************
587 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
588 ``specialise this function to these four types...'') in with type
589 signatures. Then all the machinery to move them into place, etc.,
593 type LSig name = Located (Sig name)
595 data Sig name -- Signatures and pragmas
596 = -- An ordinary type signature
597 -- f :: Num a => a -> a
598 TypeSig (Located name) (LHsType name)
600 -- A type signature for a default method inside a class
601 -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
602 | GenericSig (Located name) (LHsType name)
604 -- A type signature in generated code, notably the code
605 -- generated for record selectors. We simply record
606 -- the desired Id itself, replete with its name, type
607 -- and IdDetails. Otherwise it's just like a type
608 -- signature: there should be an accompanying binding
611 -- An ordinary fixity declaration
613 | FixSig (FixitySig name)
617 | InlineSig (Located name) -- Function name
618 InlinePragma -- Never defaultInlinePragma
620 -- A specialisation pragma
621 -- {-# SPECIALISE f :: Int -> Int #-}
622 | SpecSig (Located name) -- Specialise a function or datatype ...
623 (LHsType name) -- ... to these types
624 InlinePragma -- The pragma on SPECIALISE_INLINE form
625 -- If it's just defaultInlinePragma, then we said
626 -- SPECIALISE, not SPECIALISE_INLINE
628 -- A specialisation pragma for instance declarations only
629 -- {-# SPECIALISE instance Eq [Int] #-}
630 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
631 -- current instance decl
632 deriving (Data, Typeable)
635 type LFixitySig name = Located (FixitySig name)
636 data FixitySig name = FixitySig (Located name) Fixity
637 deriving (Data, Typeable)
639 -- TsSpecPrags conveys pragmas from the type checker to the desugarer
641 = IsDefaultMethod -- Super-specialised: a default method should
642 -- be macro-expanded at every call site
643 | SpecPrags [LTcSpecPrag]
644 deriving (Data, Typeable)
646 type LTcSpecPrag = Located TcSpecPrag
650 Id -- The Id to be specialised
651 HsWrapper -- An wrapper, that specialises the polymorphic function
652 InlinePragma -- Inlining spec for the specialised function
653 deriving (Data, Typeable)
655 noSpecPrags :: TcSpecPrags
656 noSpecPrags = SpecPrags []
658 hasSpecPrags :: TcSpecPrags -> Bool
659 hasSpecPrags (SpecPrags ps) = not (null ps)
660 hasSpecPrags IsDefaultMethod = False
662 isDefaultMethod :: TcSpecPrags -> Bool
663 isDefaultMethod IsDefaultMethod = True
664 isDefaultMethod (SpecPrags {}) = False
669 okBindSig :: Sig a -> Bool
672 okHsBootSig :: Sig a -> Bool
673 okHsBootSig (TypeSig _ _) = True
674 okHsBootSig (GenericSig _ _) = False
675 okHsBootSig (FixSig _) = True
676 okHsBootSig _ = False
678 okClsDclSig :: Sig a -> Bool
679 okClsDclSig (SpecInstSig _) = False
680 okClsDclSig _ = True -- All others OK
682 okInstDclSig :: Sig a -> Bool
683 okInstDclSig (TypeSig _ _) = False
684 okInstDclSig (GenericSig _ _) = False
685 okInstDclSig (FixSig _) = False
686 okInstDclSig _ = True
688 sigName :: LSig name -> Maybe name
689 -- Used only in Haddock
690 sigName (L _ sig) = sigNameNoLoc sig
692 sigNameNoLoc :: Sig name -> Maybe name
693 -- Used only in Haddock
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 _(GenericSig {})) = True
713 isTypeLSig (L _(IdSig {})) = True
716 isSpecLSig :: LSig name -> Bool
717 isSpecLSig (L _(SpecSig {})) = True
720 isSpecInstLSig :: LSig name -> Bool
721 isSpecInstLSig (L _ (SpecInstSig {})) = True
722 isSpecInstLSig _ = False
724 isPragLSig :: LSig name -> Bool
725 -- Identifies pragmas
726 isPragLSig (L _ (SpecSig {})) = True
727 isPragLSig (L _ (InlineSig {})) = True
730 isInlineLSig :: LSig name -> Bool
731 -- Identifies inline pragmas
732 isInlineLSig (L _ (InlineSig {})) = True
733 isInlineLSig _ = False
735 hsSigDoc :: Sig name -> SDoc
736 hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
737 hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
738 hsSigDoc (IdSig {}) = ptext (sLit "id signature")
739 hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
740 hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
741 hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma")
742 hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration")
745 Signature equality is used when checking for duplicate signatures
748 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
749 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
750 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
751 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
752 eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2
753 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
754 -- For specialisations, we don't have equality over
755 -- HsType, so it's not convenient to spot duplicate
756 -- specialisations here. Check for this later, when we're in Type land
757 eqHsSig _other1 _other2 = False
761 instance (OutputableBndr name) => Outputable (Sig name) where
762 ppr sig = ppr_sig sig
764 ppr_sig :: OutputableBndr name => Sig name -> SDoc
765 ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
766 ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty)
767 ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
768 ppr_sig (FixSig fix_sig) = ppr fix_sig
769 ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
770 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
771 ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
773 instance Outputable name => Outputable (FixitySig name) where
774 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
776 pragBrackets :: SDoc -> SDoc
777 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
779 pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
780 pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
782 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
783 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
785 pp_inl | isDefaultInlinePragma inl = empty
786 | otherwise = ppr inl
788 pprTcSpecPrags :: TcSpecPrags -> SDoc
789 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
790 pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
792 instance Outputable TcSpecPrag where
793 ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl