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@.
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
19 #include "HsVersions.h"
21 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
22 MatchGroup, pprFunBind,
24 import {-# SOURCE #-} HsPat ( LPat )
40 %************************************************************************
42 \subsection{Bindings: @BindGroup@}
44 %************************************************************************
46 Global bindings (where clauses)
49 -- During renaming, we need bindings where the left-hand sides
50 -- have been renamed but the the right-hand sides have not.
51 -- the ...LR datatypes are parametrized by two id types,
52 -- one for the left and one for the right.
53 -- Other than during renaming, these will be the same.
55 type HsLocalBinds id = HsLocalBindsLR id id
57 data HsLocalBindsLR idL idR -- Bindings in a 'let' expression
58 -- or a 'where' clause
59 = HsValBinds (HsValBindsLR idL idR)
60 | HsIPBinds (HsIPBinds idR)
63 type HsValBinds id = HsValBindsLR id id
65 data HsValBindsLR idL idR -- Value bindings (not implicit parameters)
66 = ValBindsIn -- Before typechecking
67 (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
68 -- Recursive by default
70 | ValBindsOut -- After renaming
71 [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
72 -- in the list may depend on earlier
76 type LHsBinds id = Bag (LHsBind id)
77 type DictBinds id = LHsBinds id -- Used for dictionary or method bindings
78 type LHsBind id = Located (HsBind id)
79 type HsBind id = HsBindLR id id
81 type LHsBindLR idL idR = Located (HsBindLR idL idR)
82 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
85 = FunBind { -- FunBind is used for both functions f x = e
86 -- and variables f = \x -> e
87 -- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds
89 -- Reason 2: instance decls can only have FunBinds, which is convenient
90 -- If you change this, you'll need tochange e.g. rnMethodBinds
92 -- But note that the form f :: a->a = ...
93 -- parses as a pattern binding, just like
94 -- (f :: a -> a) = ...
96 fun_id :: Located idL,
98 fun_infix :: Bool, -- True => infix declaration
100 fun_matches :: MatchGroup idR, -- The payload
102 fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of
104 -- f :: Int -> forall a. a -> a
106 -- Then the MatchGroup will have type (Int -> a' -> a')
107 -- (with a free type variable a'). The coercion will take
108 -- a CoreExpr of this type and convert it to a CoreExpr of
109 -- type Int -> forall a'. a' -> a'
110 -- Notice that the coercion captures the free a'.
112 bind_fvs :: NameSet, -- After the renamer, this contains a superset of the
113 -- Names of the other binders in this binding group that
114 -- are free in the RHS of the defn
115 -- Before renaming, and after typechecking,
116 -- the field is unused; it's just an error thunk
118 fun_tick :: Maybe (Int,[idR]) -- This is the (optional) module-local tick number.
121 | PatBind { -- The pattern is never a simple variable;
122 -- That case is done by FunBind
124 pat_rhs :: GRHSs idR,
125 pat_rhs_ty :: PostTcType, -- Type of the GRHSs
126 bind_fvs :: NameSet -- Same as for FunBind
129 | VarBind { -- Dictionary binding and suchlike
130 var_id :: idL, -- All VarBinds are introduced by the type checker
131 var_rhs :: LHsExpr idR -- Located only for consistency
134 | AbsBinds { -- Binds abstraction; TRANSLATION
136 abs_dicts :: [DictId],
137 -- AbsBinds only gets used when idL = idR after renaming,
138 -- but these need to be idL's for the collect... code in HsUtil to have
140 abs_exports :: [([TyVar], idL, idL, [LPrag])], -- (tvs, poly_id, mono_id, prags)
141 abs_binds :: LHsBinds idL -- The dictionary bindings and typechecked user bindings
142 -- mixed up together; you can tell the dict bindings because
143 -- they are all VarBinds
145 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
147 -- Creates bindings for (polymorphic, overloaded) poly_f
148 -- in terms of monomorphic, non-overloaded mono_f
151 -- 1. 'binds' binds mono_f
152 -- 2. ftvs is a subset of tvs
153 -- 3. ftvs includes all tyvars free in ds
155 -- See section 9 of static semantics paper for more details.
156 -- (You can get a PhD for explaining the True Meaning
157 -- of this last construct.)
159 placeHolderNames :: NameSet
160 -- Used for the NameSet in FunBind and PatBind prior to the renamer
161 placeHolderNames = panic "placeHolderNames"
164 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
165 ppr (HsValBinds bs) = ppr bs
166 ppr (HsIPBinds bs) = ppr bs
167 ppr EmptyLocalBinds = empty
169 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
170 ppr (ValBindsIn binds sigs)
171 = pprValBindsForUser binds sigs
173 ppr (ValBindsOut sccs sigs)
174 = getPprStyle $ \ sty ->
175 if debugStyle sty then -- Print with sccs showing
176 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
178 pprValBindsForUser (unionManyBags (map snd sccs)) sigs
180 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
181 pp_rec Recursive = ptext SLIT("rec")
182 pp_rec NonRecursive = ptext SLIT("nonrec")
184 -- *not* pprLHsBinds because we don't want braces; 'let' and
185 -- 'where' include a list of HsBindGroups and we don't want
186 -- several groups of bindings each with braces around.
187 -- Sort by location before printing
188 pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
189 => LHsBindsLR idL idR -> [LSig id2] -> SDoc
190 pprValBindsForUser binds sigs
191 = pprDeeperList vcat (map snd (sort_by_loc decls))
194 decls :: [(SrcSpan, SDoc)]
195 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
196 [(loc, ppr bind) | L loc bind <- bagToList binds]
198 sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
200 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
202 | isEmptyLHsBinds binds = empty
203 | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
206 emptyLocalBinds :: HsLocalBindsLR a b
207 emptyLocalBinds = EmptyLocalBinds
209 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
210 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
211 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
212 isEmptyLocalBinds EmptyLocalBinds = True
214 isEmptyValBinds :: HsValBindsLR a b -> Bool
215 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
216 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
218 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
219 emptyValBindsIn = ValBindsIn emptyBag []
220 emptyValBindsOut = ValBindsOut [] []
222 emptyLHsBinds :: LHsBindsLR idL idR
223 emptyLHsBinds = emptyBag
225 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
226 isEmptyLHsBinds = isEmptyBag
229 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
230 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
231 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
232 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
233 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
245 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
248 gp = ...same again, with gm instead of fm
250 This is a pretty bad translation, because it duplicates all the bindings.
251 So the desugarer tries to do a better job:
253 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
257 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
261 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
262 ppr mbind = ppr_monobind mbind
264 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
266 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
267 ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
268 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
269 fun_matches = matches,
273 Just t -> text "-- tick id = " <> ppr t
274 ) $$ pprFunBind (unLoc fun) inf matches
276 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
277 abs_exports = exports, abs_binds = val_binds })
278 = sep [ptext SLIT("AbsBinds"),
279 brackets (interpp'SP tyvars),
280 brackets (interpp'SP dictvars),
281 brackets (sep (punctuate comma (map ppr_exp exports)))]
283 nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
284 -- Print type signatures
285 $$ pprLHsBinds val_binds )
287 ppr_exp (tvs, gbl, lcl, prags)
288 = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
289 nest 2 (vcat (map (pprPrag gbl) prags))]
292 %************************************************************************
294 Implicit parameter bindings
296 %************************************************************************
302 (DictBinds id) -- Only in typechecker output; binds
303 -- uses of the implicit parameters
305 isEmptyIPBinds :: HsIPBinds id -> Bool
306 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
308 type LIPBind id = Located (IPBind id)
310 -- | Implicit parameter bindings.
316 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
317 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
320 instance (OutputableBndr id) => Outputable (IPBind id) where
321 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
325 %************************************************************************
327 \subsection{Coercion functions}
329 %************************************************************************
332 -- A HsWrapper is an expression with a hole in it
333 -- We need coercions to have concrete form so that we can zonk them
336 = WpHole -- The identity coercion
338 | WpCompose HsWrapper HsWrapper -- (\a1..an. []) `WpCompose` (\x1..xn. [])
339 -- = (\a1..an \x1..xn. [])
341 | WpCo Coercion -- A cast: [] `cast` co
342 -- Guaranteedn not the identity coercion
344 | WpApp Var -- [] d the 'd' is a type-class dictionary
345 | WpTyApp Type -- [] t the 't' is a type or corecion
346 | WpLam Id -- \d. [] the 'd' is a type-class dictionary
347 | WpTyLam TyVar -- \a. [] the 'a' is a type or coercion variable
348 | WpInline -- inline_me [] Wrap inline around the thing
350 -- Non-empty bindings, so that the identity coercion
351 -- is always exactly WpHole
352 | WpLet (LHsBinds Id) -- let binds in []
353 -- (would be nicer to be core bindings)
355 instance Outputable HsWrapper where
356 ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn
358 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
359 pprHsWrapper it wrap =
362 help it (WpCompose f1 f2) = help (help it f2) f1
363 help it (WpCo co) = sep [it, nest 2 (ptext SLIT("`cast`") <+> pprParendType co)]
364 help it (WpApp id) = sep [it, nest 2 (ppr id)]
365 help it (WpTyApp ty) = sep [it, ptext SLIT("@") <+> pprParendType ty]
366 help it (WpLam id) = sep [ptext SLIT("\\") <> pprBndr LambdaBind id <> dot, it]
367 help it (WpTyLam tv) = sep [ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot, it]
368 help it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
369 help it WpInline = sep [ptext SLIT("_inline_me_"), it]
371 -- in debug mode, print the wrapper
372 -- otherwise just print what's inside
373 getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
375 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
378 c1 <.> c2 = c1 `WpCompose` c2
380 mkWpTyApps :: [Type] -> HsWrapper
381 mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
383 mkWpApps :: [Id] -> HsWrapper
384 mkWpApps ids = mk_co_fn WpApp (reverse ids)
386 mkWpTyLams :: [TyVar] -> HsWrapper
387 mkWpTyLams ids = mk_co_fn WpTyLam ids
389 mkWpLams :: [Id] -> HsWrapper
390 mkWpLams ids = mk_co_fn WpLam ids
392 mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
393 mk_co_fn f as = foldr (WpCompose . f) WpHole as
395 idHsWrapper :: HsWrapper
398 isIdHsWrapper :: HsWrapper -> Bool
399 isIdHsWrapper WpHole = True
400 isIdHsWrapper other = False
404 %************************************************************************
406 \subsection{@Sig@: type signatures and value-modifying user pragmas}
408 %************************************************************************
410 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
411 ``specialise this function to these four types...'') in with type
412 signatures. Then all the machinery to move them into place, etc.,
416 type LSig name = Located (Sig name)
418 data Sig name -- Signatures and pragmas
419 = -- An ordinary type signature
420 -- f :: Num a => a -> a
421 TypeSig (Located name) -- A bog-std type signature
424 -- An ordinary fixity declaration
426 | FixSig (FixitySig name) -- Fixity declaration
430 | InlineSig (Located name) -- Function name
433 -- A specialisation pragma
434 -- {-# SPECIALISE f :: Int -> Int #-}
435 | SpecSig (Located name) -- Specialise a function or datatype ...
436 (LHsType name) -- ... to these types
439 -- A specialisation pragma for instance declarations only
440 -- {-# SPECIALISE instance Eq [Int] #-}
441 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
442 -- current instance decl
445 type LFixitySig name = Located (FixitySig name)
446 data FixitySig name = FixitySig (Located name) Fixity
448 -- A Prag conveys pragmas from the type checker to the desugarer
449 type LPrag = Located Prag
455 (HsExpr Id) -- An expression, of the given specialised type, which
456 PostTcType -- specialises the polymorphic function
457 [Id] -- Dicts mentioned free in the expression
458 -- Apr07: I think this is pretty useless
459 -- see Note [Const rule dicts] in DsBinds
460 InlineSpec -- Inlining spec for the specialised function
462 isInlinePrag (InlinePrag _) = True
463 isInlinePrag prag = False
465 isSpecPrag (SpecPrag {}) = True
466 isSpecPrag prag = False
470 okBindSig :: NameSet -> LSig Name -> Bool
471 okBindSig ns sig = sigForThisGroup ns sig
473 okHsBootSig :: LSig Name -> Bool
474 okHsBootSig (L _ (TypeSig _ _)) = True
475 okHsBootSig (L _ (FixSig _)) = True
476 okHsBootSig sig = False
478 okClsDclSig :: LSig Name -> Bool
479 okClsDclSig (L _ (SpecInstSig _)) = False
480 okClsDclSig sig = True -- All others OK
482 okInstDclSig :: NameSet -> LSig Name -> Bool
483 okInstDclSig ns lsig@(L _ sig) = ok ns sig
485 ok ns (TypeSig _ _) = False
486 ok ns (FixSig _) = False
487 ok ns (SpecInstSig _) = True
488 ok ns sig = sigForThisGroup ns lsig
490 sigForThisGroup :: NameSet -> LSig Name -> Bool
491 sigForThisGroup ns sig
492 = case sigName sig of
494 Just n -> n `elemNameSet` ns
496 sigName :: LSig name -> Maybe name
497 sigName (L _ sig) = sigNameNoLoc sig
499 sigNameNoLoc :: Sig name -> Maybe name
500 sigNameNoLoc (TypeSig n _) = Just (unLoc n)
501 sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)
502 sigNameNoLoc (InlineSig n _) = Just (unLoc n)
503 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
504 sigNameNoLoc other = Nothing
506 isFixityLSig :: LSig name -> Bool
507 isFixityLSig (L _ (FixSig {})) = True
508 isFixityLSig _ = False
510 isVanillaLSig :: LSig name -> Bool
511 isVanillaLSig (L _(TypeSig {})) = True
512 isVanillaLSig sig = False
514 isSpecLSig :: LSig name -> Bool
515 isSpecLSig (L _(SpecSig {})) = True
516 isSpecLSig sig = False
518 isSpecInstLSig (L _ (SpecInstSig {})) = True
519 isSpecInstLSig sig = False
521 isPragLSig :: LSig name -> Bool
522 -- Identifies pragmas
523 isPragLSig (L _ (SpecSig {})) = True
524 isPragLSig (L _ (InlineSig {})) = True
525 isPragLSig other = False
527 isInlineLSig :: LSig name -> Bool
528 -- Identifies inline pragmas
529 isInlineLSig (L _ (InlineSig {})) = True
530 isInlineLSig other = False
532 hsSigDoc (TypeSig {}) = ptext SLIT("type signature")
533 hsSigDoc (SpecSig {}) = ptext SLIT("SPECIALISE pragma")
534 hsSigDoc (InlineSig _ spec) = ptext SLIT("INLINE pragma")
535 hsSigDoc (SpecInstSig {}) = ptext SLIT("SPECIALISE instance pragma")
536 hsSigDoc (FixSig {}) = ptext SLIT("fixity declaration")
539 Signature equality is used when checking for duplicate signatures
542 eqHsSig :: LSig Name -> LSig Name -> Bool
543 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
544 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
545 eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2)) = unLoc n1 == unLoc n2
546 -- For specialisations, we don't have equality over
547 -- HsType, so it's not convenient to spot duplicate
548 -- specialisations here. Check for this later, when we're in Type land
549 eqHsSig _other1 _other2 = False
553 instance (OutputableBndr name) => Outputable (Sig name) where
554 ppr sig = ppr_sig sig
556 ppr_sig :: OutputableBndr name => Sig name -> SDoc
557 ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty
558 ppr_sig (FixSig fix_sig) = ppr fix_sig
559 ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl)
560 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
561 ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
563 instance Outputable name => Outputable (FixitySig name) where
564 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
566 pragBrackets :: SDoc -> SDoc
567 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
569 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
570 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
572 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
573 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
575 pprPrag :: Outputable id => id -> LPrag -> SDoc
576 pprPrag var (L _ (InlinePrag inl)) = ppr inl <+> ppr var
577 pprPrag var (L _ (SpecPrag expr ty _ inl)) = pprSpec var ty inl