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 data HsLocalBinds id -- Bindings in a 'let' expression
50 -- or a 'where' clause
51 = HsValBinds (HsValBinds id)
52 | HsIPBinds (HsIPBinds id)
56 data HsValBinds id -- Value bindings (not implicit parameters)
57 = ValBindsIn -- Before typechecking
58 (LHsBinds id) [LSig id] -- Not dependency analysed
59 -- Recursive by default
61 | ValBindsOut -- After renaming
62 [(RecFlag, LHsBinds id)] -- Dependency analysed, later bindings
63 -- in the list may depend on earlier
67 type LHsBinds id = Bag (LHsBind id)
68 type DictBinds id = LHsBinds id -- Used for dictionary or method bindings
69 type LHsBind id = Located (HsBind id)
72 = FunBind { -- FunBind is used for both functions f x = e
73 -- and variables f = \x -> e
74 -- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds
76 -- Reason 2: instance decls can only have FunBinds, which is convenient
77 -- If you change this, you'll need tochange e.g. rnMethodBinds
79 -- But note that the form f :: a->a = ...
80 -- parses as a pattern binding, just like
81 -- (f :: a -> a) = ...
85 fun_infix :: Bool, -- True => infix declaration
87 fun_matches :: MatchGroup id, -- The payload
89 fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of
91 -- f :: Int -> forall a. a -> a
93 -- Then the MatchGroup will have type (Int -> a' -> a')
94 -- (with a free type variable a'). The coercion will take
95 -- a CoreExpr of this type and convert it to a CoreExpr of
96 -- type Int -> forall a'. a' -> a'
97 -- Notice that the coercion captures the free a'.
99 bind_fvs :: NameSet, -- After the renamer, this contains a superset of the
100 -- Names of the other binders in this binding group that
101 -- are free in the RHS of the defn
102 -- Before renaming, and after typechecking,
103 -- the field is unused; it's just an error thunk
105 fun_tick :: Maybe (Int,[id]) -- This is the (optional) module-local tick number.
108 | PatBind { -- The pattern is never a simple variable;
109 -- That case is done by FunBind
112 pat_rhs_ty :: PostTcType, -- Type of the GRHSs
113 bind_fvs :: NameSet -- Same as for FunBind
116 | VarBind { -- Dictionary binding and suchlike
117 var_id :: id, -- All VarBinds are introduced by the type checker
118 var_rhs :: LHsExpr id -- Located only for consistency
121 | AbsBinds { -- Binds abstraction; TRANSLATION
123 abs_dicts :: [DictId],
124 abs_exports :: [([TyVar], id, id, [LPrag])], -- (tvs, poly_id, mono_id, prags)
125 abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings
126 -- mixed up together; you can tell the dict bindings because
127 -- they are all VarBinds
129 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
131 -- Creates bindings for (polymorphic, overloaded) poly_f
132 -- in terms of monomorphic, non-overloaded mono_f
135 -- 1. 'binds' binds mono_f
136 -- 2. ftvs is a subset of tvs
137 -- 3. ftvs includes all tyvars free in ds
139 -- See section 9 of static semantics paper for more details.
140 -- (You can get a PhD for explaining the True Meaning
141 -- of this last construct.)
143 placeHolderNames :: NameSet
144 -- Used for the NameSet in FunBind and PatBind prior to the renamer
145 placeHolderNames = panic "placeHolderNames"
148 instance OutputableBndr id => Outputable (HsLocalBinds id) where
149 ppr (HsValBinds bs) = ppr bs
150 ppr (HsIPBinds bs) = ppr bs
151 ppr EmptyLocalBinds = empty
153 instance OutputableBndr id => Outputable (HsValBinds id) where
154 ppr (ValBindsIn binds sigs)
155 = pprValBindsForUser binds sigs
157 ppr (ValBindsOut sccs sigs)
158 = getPprStyle $ \ sty ->
159 if debugStyle sty then -- Print with sccs showing
160 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
162 pprValBindsForUser (unionManyBags (map snd sccs)) sigs
164 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
165 pp_rec Recursive = ptext SLIT("rec")
166 pp_rec NonRecursive = ptext SLIT("nonrec")
168 -- *not* pprLHsBinds because we don't want braces; 'let' and
169 -- 'where' include a list of HsBindGroups and we don't want
170 -- several groups of bindings each with braces around.
171 -- Sort by location before printing
172 pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2)
173 => LHsBinds id1 -> [LSig id2] -> SDoc
174 pprValBindsForUser binds sigs
175 = pprDeeperList vcat (map snd (sort_by_loc decls))
178 decls :: [(SrcSpan, SDoc)]
179 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
180 [(loc, ppr bind) | L loc bind <- bagToList binds]
182 sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
184 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
186 | isEmptyLHsBinds binds = empty
187 | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
190 emptyLocalBinds :: HsLocalBinds a
191 emptyLocalBinds = EmptyLocalBinds
193 isEmptyLocalBinds :: HsLocalBinds a -> Bool
194 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
195 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
196 isEmptyLocalBinds EmptyLocalBinds = True
198 isEmptyValBinds :: HsValBinds a -> Bool
199 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
200 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
202 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
203 emptyValBindsIn = ValBindsIn emptyBag []
204 emptyValBindsOut = ValBindsOut [] []
206 emptyLHsBinds :: LHsBinds id
207 emptyLHsBinds = emptyBag
209 isEmptyLHsBinds :: LHsBinds id -> Bool
210 isEmptyLHsBinds = isEmptyBag
213 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
214 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
215 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
216 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
217 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
229 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
232 gp = ...same again, with gm instead of fm
234 This is a pretty bad translation, because it duplicates all the bindings.
235 So the desugarer tries to do a better job:
237 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
241 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
245 instance OutputableBndr id => Outputable (HsBind id) where
246 ppr mbind = ppr_monobind mbind
248 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
250 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
251 ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
252 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
253 fun_matches = matches,
257 Just t -> text "-- tick id = " <> ppr t
258 ) $$ pprFunBind (unLoc fun) inf matches
260 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
261 abs_exports = exports, abs_binds = val_binds })
262 = sep [ptext SLIT("AbsBinds"),
263 brackets (interpp'SP tyvars),
264 brackets (interpp'SP dictvars),
265 brackets (sep (punctuate comma (map ppr_exp exports)))]
267 nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
268 -- Print type signatures
269 $$ pprLHsBinds val_binds )
271 ppr_exp (tvs, gbl, lcl, prags)
272 = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
273 nest 2 (vcat (map (pprPrag gbl) prags))]
276 %************************************************************************
278 Implicit parameter bindings
280 %************************************************************************
286 (DictBinds id) -- Only in typechecker output; binds
287 -- uses of the implicit parameters
289 isEmptyIPBinds :: HsIPBinds id -> Bool
290 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
292 type LIPBind id = Located (IPBind id)
294 -- | Implicit parameter bindings.
300 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
301 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
304 instance (OutputableBndr id) => Outputable (IPBind id) where
305 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
309 %************************************************************************
311 \subsection{Coercion functions}
313 %************************************************************************
316 -- A HsWrapper is an expression with a hole in it
317 -- We need coercions to have concrete form so that we can zonk them
320 = WpHole -- The identity coercion
322 | WpCompose HsWrapper HsWrapper -- (\a1..an. []) `WpCompose` (\x1..xn. [])
323 -- = (\a1..an \x1..xn. [])
325 | WpCo Coercion -- A cast: [] `cast` co
326 -- Guaranteedn not the identity coercion
328 | WpApp Var -- [] d the 'd' is a type-class dictionary
329 | WpTyApp Type -- [] t the 't' is a type or corecion
330 | WpLam Id -- \d. [] the 'd' is a type-class dictionary
331 | WpTyLam TyVar -- \a. [] the 'a' is a type or coercion variable
333 -- Non-empty bindings, so that the identity coercion
334 -- is always exactly WpHole
335 | WpLet (LHsBinds Id) -- let binds in []
336 -- (would be nicer to be core bindings)
338 instance Outputable HsWrapper where
339 ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn
341 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
342 pprHsWrapper it WpHole = it
343 pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1
344 pprHsWrapper it (WpCo co) = it <+> ptext SLIT("`cast`") <+> pprParendType co
345 pprHsWrapper it (WpApp id) = it <+> ppr id
346 pprHsWrapper it (WpTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty
347 pprHsWrapper it (WpLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it
348 pprHsWrapper it (WpTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it
349 pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
351 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
354 c1 <.> c2 = c1 `WpCompose` c2
356 mkWpTyApps :: [Type] -> HsWrapper
357 mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
359 mkWpApps :: [Id] -> HsWrapper
360 mkWpApps ids = mk_co_fn WpApp (reverse ids)
362 mkWpTyLams :: [TyVar] -> HsWrapper
363 mkWpTyLams ids = mk_co_fn WpTyLam ids
365 mkWpLams :: [Id] -> HsWrapper
366 mkWpLams ids = mk_co_fn WpLam ids
368 mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
369 mk_co_fn f as = foldr (WpCompose . f) WpHole as
371 idHsWrapper :: HsWrapper
374 isIdHsWrapper :: HsWrapper -> Bool
375 isIdHsWrapper WpHole = True
376 isIdHsWrapper other = False
380 %************************************************************************
382 \subsection{@Sig@: type signatures and value-modifying user pragmas}
384 %************************************************************************
386 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
387 ``specialise this function to these four types...'') in with type
388 signatures. Then all the machinery to move them into place, etc.,
392 type LSig name = Located (Sig name)
394 data Sig name -- Signatures and pragmas
395 = -- An ordinary type signature
396 -- f :: Num a => a -> a
397 TypeSig (Located name) -- A bog-std type signature
400 -- An ordinary fixity declaration
402 | FixSig (FixitySig name) -- Fixity declaration
406 | InlineSig (Located name) -- Function name
409 -- A specialisation pragma
410 -- {-# SPECIALISE f :: Int -> Int #-}
411 | SpecSig (Located name) -- Specialise a function or datatype ...
412 (LHsType name) -- ... to these types
415 -- A specialisation pragma for instance declarations only
416 -- {-# SPECIALISE instance Eq [Int] #-}
417 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
418 -- current instance decl
421 type LFixitySig name = Located (FixitySig name)
422 data FixitySig name = FixitySig (Located name) Fixity
424 -- A Prag conveys pragmas from the type checker to the desugarer
425 type LPrag = Located Prag
431 (HsExpr Id) -- An expression, of the given specialised type, which
432 PostTcType -- specialises the polymorphic function
433 [Id] -- Dicts mentioned free in the expression
434 -- Apr07: I think this is pretty useless
435 -- see Note [Const rule dicts] in DsBinds
436 InlineSpec -- Inlining spec for the specialised function
438 isInlinePrag (InlinePrag _) = True
439 isInlinePrag prag = False
441 isSpecPrag (SpecPrag {}) = True
442 isSpecPrag prag = False
446 okBindSig :: NameSet -> LSig Name -> Bool
447 okBindSig ns sig = sigForThisGroup ns sig
449 okHsBootSig :: LSig Name -> Bool
450 okHsBootSig (L _ (TypeSig _ _)) = True
451 okHsBootSig (L _ (FixSig _)) = True
452 okHsBootSig sig = False
454 okClsDclSig :: LSig Name -> Bool
455 okClsDclSig (L _ (SpecInstSig _)) = False
456 okClsDclSig sig = True -- All others OK
458 okInstDclSig :: NameSet -> LSig Name -> Bool
459 okInstDclSig ns lsig@(L _ sig) = ok ns sig
461 ok ns (TypeSig _ _) = False
462 ok ns (FixSig _) = False
463 ok ns (SpecInstSig _) = True
464 ok ns sig = sigForThisGroup ns lsig
466 sigForThisGroup :: NameSet -> LSig Name -> Bool
467 sigForThisGroup ns sig
468 = case sigName sig of
470 Just n -> n `elemNameSet` ns
472 sigName :: LSig name -> Maybe name
473 sigName (L _ sig) = sigNameNoLoc sig
475 sigNameNoLoc :: Sig name -> Maybe name
476 sigNameNoLoc (TypeSig n _) = Just (unLoc n)
477 sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)
478 sigNameNoLoc (InlineSig n _) = Just (unLoc n)
479 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
480 sigNameNoLoc other = Nothing
482 isFixityLSig :: LSig name -> Bool
483 isFixityLSig (L _ (FixSig {})) = True
484 isFixityLSig _ = False
486 isVanillaLSig :: LSig name -> Bool
487 isVanillaLSig (L _(TypeSig {})) = True
488 isVanillaLSig sig = False
490 isSpecLSig :: LSig name -> Bool
491 isSpecLSig (L _(SpecSig {})) = True
492 isSpecLSig sig = False
494 isSpecInstLSig (L _ (SpecInstSig {})) = True
495 isSpecInstLSig sig = False
497 isPragLSig :: LSig name -> Bool
498 -- Identifies pragmas
499 isPragLSig (L _ (SpecSig {})) = True
500 isPragLSig (L _ (InlineSig {})) = True
501 isPragLSig other = False
503 isInlineLSig :: LSig name -> Bool
504 -- Identifies inline pragmas
505 isInlineLSig (L _ (InlineSig {})) = True
506 isInlineLSig other = False
508 hsSigDoc (TypeSig {}) = ptext SLIT("type signature")
509 hsSigDoc (SpecSig {}) = ptext SLIT("SPECIALISE pragma")
510 hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma")
511 hsSigDoc (SpecInstSig {}) = ptext SLIT("SPECIALISE instance pragma")
512 hsSigDoc (FixSig {}) = ptext SLIT("fixity declaration")
515 Signature equality is used when checking for duplicate signatures
518 eqHsSig :: LSig Name -> LSig Name -> Bool
519 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
520 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
521 eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2)) = s1 == s2 && unLoc n1 == unLoc n2
522 -- For specialisations, we don't have equality over
523 -- HsType, so it's not convenient to spot duplicate
524 -- specialisations here. Check for this later, when we're in Type land
525 eqHsSig _other1 _other2 = False
529 instance (OutputableBndr name) => Outputable (Sig name) where
530 ppr sig = ppr_sig sig
532 ppr_sig :: OutputableBndr name => Sig name -> SDoc
533 ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty
534 ppr_sig (FixSig fix_sig) = ppr fix_sig
535 ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl)
536 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
537 ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
539 instance Outputable name => Outputable (FixitySig name) where
540 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
542 pragBrackets :: SDoc -> SDoc
543 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
545 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
546 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
548 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
549 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
551 pprPrag :: Outputable id => id -> LPrag -> SDoc
552 pprPrag var (L _ (InlinePrag inl)) = ppr inl <+> ppr var
553 pprPrag var (L _ (SpecPrag expr ty _ inl)) = pprSpec var ty inl