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)
259 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
262 gp = ...same again, with gm instead of fm
264 This is a pretty bad translation, because it duplicates all the bindings.
265 So the desugarer tries to do a better job:
267 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
271 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
275 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
276 ppr mbind = ppr_monobind mbind
278 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
280 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
281 ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs)
282 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
283 fun_matches = matches,
285 = pprTicks empty (case tick of
287 Just t -> text "-- tick id = " <> ppr t)
288 $$ pprFunBind (unLoc fun) inf matches
290 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars,
291 abs_exports = exports, abs_binds = val_binds })
292 = sep [ptext (sLit "AbsBinds"),
293 brackets (interpp'SP tyvars),
294 brackets (interpp'SP dictvars),
295 brackets (sep (punctuate comma (map ppr_exp exports)))]
297 nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
298 -- Print type signatures
299 $$ pprLHsBinds val_binds )
301 ppr_exp (tvs, gbl, lcl, prags)
302 = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
303 nest 2 (pprTcSpecPrags gbl prags)]
308 pprTicks :: SDoc -> SDoc -> SDoc
309 -- Print stuff about ticks only when -dppr-debug is on, to avoid
310 -- them appearing in error messages (from the desugarer); see Trac # 3263
311 pprTicks pp_no_debug pp_when_debug
312 = getPprStyle (\ sty -> if debugStyle sty then pp_when_debug
316 %************************************************************************
318 Implicit parameter bindings
320 %************************************************************************
326 TcEvBinds -- Only in typechecker output; binds
327 -- uses of the implicit parameters
328 deriving (Data, Typeable)
330 isEmptyIPBinds :: HsIPBinds id -> Bool
331 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
333 type LIPBind id = Located (IPBind id)
335 -- | Implicit parameter bindings.
340 deriving (Data, Typeable)
342 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
343 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
346 instance (OutputableBndr id) => Outputable (IPBind id) where
347 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
351 %************************************************************************
353 \subsection{Coercion functions}
355 %************************************************************************
358 -- A HsWrapper is an expression with a hole in it
359 -- We need coercions to have concrete form so that we can zonk them
362 = WpHole -- The identity coercion
364 | WpCompose HsWrapper HsWrapper
365 -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]]
367 -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. [])
368 -- But ([] a) `WpCompose` ([] b) = ([] b a)
370 | WpCast Coercion -- A cast: [] `cast` co
371 -- Guaranteed not the identity coercion
373 -- Evidence abstraction and application
374 -- (both dictionaries and coercions)
375 | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable
376 | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint
378 -- Type abstraction and application
379 | WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
380 | WpTyApp Type -- [] t the 't' is a type (not coercion)
383 | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
384 -- so that the identity coercion is always exactly WpHole
385 deriving (Data, Typeable)
389 = TcEvBinds -- Mutable evidence bindings
390 EvBindsVar -- Mutable because they are updated "later"
391 -- when an implication constraint is solved
393 | EvBinds -- Immutable after zonking
398 data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
399 -- The Unique is only for debug printing
402 type EvBindMap = VarEnv EvBind
404 emptyEvBindMap :: EvBindMap
405 emptyEvBindMap = emptyVarEnv
407 extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
408 extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
410 lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
411 lookupEvBind = lookupVarEnv
413 evBindMapBinds :: EvBindMap -> Bag EvBind
414 evBindMapBinds = foldVarEnv consBag emptyBag
417 instance Data TcEvBinds where
418 -- Placeholder; we can't travers into TcEvBinds
419 toConstr _ = abstractConstr "TcEvBinds"
420 gunfold _ _ = error "gunfold"
421 dataTypeOf _ = mkNoRepType "TcEvBinds"
423 -- All evidence is bound by EvBinds; no side effects
424 data EvBind = EvBind EvVar EvTerm
427 = EvId EvId -- Term-level variable-to-variable bindings
428 -- (no coercion variables! they come via EvCoercion)
430 | EvCoercion Coercion -- Coercion bindings
432 | EvCast EvVar Coercion -- d |> co
434 | EvDFunApp DFunId -- Dictionary instance application
437 | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
438 -- dictionaries, even though the former have no
439 -- selector Id. We count up from _0_
441 deriving( Data, Typeable)
443 evVarTerm :: EvVar -> EvTerm
444 evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
448 Note [EvBinds/EvTerm]
449 ~~~~~~~~~~~~~~~~~~~~~
450 How evidence is created and updated. Bindings for dictionaries,
451 and coercions and implicit parameters are carried around in TcEvBinds
452 which during constraint generation and simplification is always of the
453 form (TcEvBinds ref). After constraint simplification is finished it
454 will be transformed to t an (EvBinds ev_bag).
456 Evidence for coercions *SHOULD* be filled in using the TcEvBinds
457 However, all EvVars that correspond to *wanted* coercion terms in
458 an EvBind must be mutable variables so that they can be readily
459 inlined (by zonking) after constraint simplification is finished.
461 Conclusion: a new wanted coercion variable should be made mutable.
462 [Notice though that evidence variables that bind coercion terms
463 from super classes will be "given" and hence rigid]
467 emptyTcEvBinds :: TcEvBinds
468 emptyTcEvBinds = EvBinds emptyBag
470 isEmptyTcEvBinds :: TcEvBinds -> Bool
471 isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
472 isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
474 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
477 c1 <.> c2 = c1 `WpCompose` c2
479 mkWpTyApps :: [Type] -> HsWrapper
480 mkWpTyApps tys = mk_co_app_fn WpTyApp tys
482 mkWpEvApps :: [EvTerm] -> HsWrapper
483 mkWpEvApps args = mk_co_app_fn WpEvApp args
485 mkWpEvVarApps :: [EvVar] -> HsWrapper
486 mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
488 mkWpTyLams :: [TyVar] -> HsWrapper
489 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
491 mkWpLams :: [Var] -> HsWrapper
492 mkWpLams ids = mk_co_lam_fn WpEvLam ids
494 mkWpLet :: TcEvBinds -> HsWrapper
495 -- This no-op is a quite a common case
496 mkWpLet (EvBinds b) | isEmptyBag b = WpHole
497 mkWpLet ev_binds = WpLet ev_binds
499 mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
500 mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
502 mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
503 -- For applications, the *first* argument must
504 -- come *last* in the composition sequence
505 mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
507 idHsWrapper :: HsWrapper
510 isIdHsWrapper :: HsWrapper -> Bool
511 isIdHsWrapper WpHole = True
512 isIdHsWrapper _ = False
518 instance Outputable HsWrapper where
519 ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
521 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
522 -- In debug mode, print the wrapper
523 -- otherwise just print what's inside
525 = getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
528 help it (WpCompose f1 f2) = help (help it f2) f1
529 help it (WpCast co) = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
530 help it (WpEvApp id) = sep [it, nest 2 (ppr id)]
531 help it (WpTyApp ty) = sep [it, ptext (sLit "@") <+> pprParendType ty]
532 help it (WpEvLam id) = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
533 help it (WpTyLam tv) = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
534 help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
536 instance Outputable TcEvBinds where
537 ppr (TcEvBinds v) = ppr v
538 ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (ppr bs)
540 instance Outputable EvBindsVar where
541 ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
543 instance Outputable EvBind where
544 ppr (EvBind v e) = ppr v <+> equals <+> ppr e
546 instance Outputable EvTerm where
548 ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
549 ppr (EvCoercion co) = ppr co
550 ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
551 ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys
555 %************************************************************************
557 \subsection{@Sig@: type signatures and value-modifying user pragmas}
559 %************************************************************************
561 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
562 ``specialise this function to these four types...'') in with type
563 signatures. Then all the machinery to move them into place, etc.,
567 type LSig name = Located (Sig name)
569 data Sig name -- Signatures and pragmas
570 = -- An ordinary type signature
571 -- f :: Num a => a -> a
572 TypeSig (Located name) (LHsType name)
574 -- A type signature in generated code, notably the code
575 -- generated for record selectors. We simply record
576 -- the desired Id itself, replete with its name, type
577 -- and IdDetails. Otherwise it's just like a type
578 -- signature: there should be an accompanying binding
581 -- An ordinary fixity declaration
583 | FixSig (FixitySig name)
587 | InlineSig (Located name) -- Function name
588 InlinePragma -- Never defaultInlinePragma
590 -- A specialisation pragma
591 -- {-# SPECIALISE f :: Int -> Int #-}
592 | SpecSig (Located name) -- Specialise a function or datatype ...
593 (LHsType name) -- ... to these types
594 InlinePragma -- The pragma on SPECIALISE_INLINE form
595 -- If it's just defaultInlinePragma, then we said
596 -- SPECIALISE, not SPECIALISE_INLINE
598 -- A specialisation pragma for instance declarations only
599 -- {-# SPECIALISE instance Eq [Int] #-}
600 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
601 -- current instance decl
602 deriving (Data, Typeable)
605 type LFixitySig name = Located (FixitySig name)
606 data FixitySig name = FixitySig (Located name) Fixity
607 deriving (Data, Typeable)
609 -- TsSpecPrags conveys pragmas from the type checker to the desugarer
611 = IsDefaultMethod -- Super-specialised: a default method should
612 -- be macro-expanded at every call site
613 | SpecPrags [Located TcSpecPrag]
614 deriving (Data, Typeable)
618 HsWrapper -- An wrapper, that specialises the polymorphic function
619 InlinePragma -- Inlining spec for the specialised function
620 deriving (Data, Typeable)
622 noSpecPrags :: TcSpecPrags
623 noSpecPrags = SpecPrags []
625 hasSpecPrags :: TcSpecPrags -> Bool
626 hasSpecPrags (SpecPrags ps) = not (null ps)
627 hasSpecPrags IsDefaultMethod = False
629 isDefaultMethod :: TcSpecPrags -> Bool
630 isDefaultMethod IsDefaultMethod = True
631 isDefaultMethod (SpecPrags {}) = False
636 okBindSig :: Sig a -> Bool
639 okHsBootSig :: Sig a -> Bool
640 okHsBootSig (TypeSig _ _) = True
641 okHsBootSig (FixSig _) = True
642 okHsBootSig _ = False
644 okClsDclSig :: Sig a -> Bool
645 okClsDclSig (SpecInstSig _) = False
646 okClsDclSig _ = True -- All others OK
648 okInstDclSig :: Sig a -> Bool
649 okInstDclSig (TypeSig _ _) = False
650 okInstDclSig (FixSig _) = False
651 okInstDclSig _ = True
653 sigForThisGroup :: NameSet -> LSig Name -> Bool
654 sigForThisGroup ns sig
655 = case sigName sig of
657 Just n -> n `elemNameSet` ns
659 sigName :: LSig name -> Maybe name
660 sigName (L _ sig) = sigNameNoLoc sig
662 sigNameNoLoc :: Sig name -> Maybe name
663 sigNameNoLoc (TypeSig n _) = Just (unLoc n)
664 sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)
665 sigNameNoLoc (InlineSig n _) = Just (unLoc n)
666 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
667 sigNameNoLoc _ = Nothing
669 isFixityLSig :: LSig name -> Bool
670 isFixityLSig (L _ (FixSig {})) = True
671 isFixityLSig _ = False
673 isVanillaLSig :: LSig name -> Bool -- User type signatures
674 -- A badly-named function, but it's part of the GHCi (used
675 -- by Haddock) so I don't want to change it gratuitously.
676 isVanillaLSig (L _(TypeSig {})) = True
677 isVanillaLSig _ = False
679 isTypeLSig :: LSig name -> Bool -- Type signatures
680 isTypeLSig (L _(TypeSig {})) = True
681 isTypeLSig (L _(IdSig {})) = True
684 isSpecLSig :: LSig name -> Bool
685 isSpecLSig (L _(SpecSig {})) = True
688 isSpecInstLSig :: LSig name -> Bool
689 isSpecInstLSig (L _ (SpecInstSig {})) = True
690 isSpecInstLSig _ = False
692 isPragLSig :: LSig name -> Bool
693 -- Identifies pragmas
694 isPragLSig (L _ (SpecSig {})) = True
695 isPragLSig (L _ (InlineSig {})) = True
698 isInlineLSig :: LSig name -> Bool
699 -- Identifies inline pragmas
700 isInlineLSig (L _ (InlineSig {})) = True
701 isInlineLSig _ = False
703 hsSigDoc :: Sig name -> SDoc
704 hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
705 hsSigDoc (IdSig {}) = ptext (sLit "id signature")
706 hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
707 hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
708 hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma")
709 hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration")
712 Signature equality is used when checking for duplicate signatures
715 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
716 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
717 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
718 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
719 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
720 -- For specialisations, we don't have equality over
721 -- HsType, so it's not convenient to spot duplicate
722 -- specialisations here. Check for this later, when we're in Type land
723 eqHsSig _other1 _other2 = False
727 instance (OutputableBndr name) => Outputable (Sig name) where
728 ppr sig = ppr_sig sig
730 ppr_sig :: OutputableBndr name => Sig name -> SDoc
731 ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
732 ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
733 ppr_sig (FixSig fix_sig) = ppr fix_sig
734 ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
735 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
736 ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
738 instance Outputable name => Outputable (FixitySig name) where
739 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
741 pragBrackets :: SDoc -> SDoc
742 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
744 pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
745 pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
747 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
748 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
750 pp_inl | isDefaultInlinePragma inl = empty
751 | otherwise = ppr inl
753 pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc
754 pprTcSpecPrags _ IsDefaultMethod = ptext (sLit "<default method>")
755 pprTcSpecPrags gbl (SpecPrags ps) = vcat (map (pprSpecPrag gbl) ps)
757 pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc
758 pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
760 instance Outputable TcSpecPrag where
761 ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p