2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
6 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
11 #include "HsVersions.h"
13 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
14 MatchGroup, pprFunBind,
16 import {-# SOURCE #-} HsPat ( LPat )
18 import HsTypes ( LHsType, PostTcType )
19 import PprCore ( {- instances -} )
20 import Coercion ( Coercion )
21 import Type ( Type, pprParendType )
23 import NameSet ( NameSet, elemNameSet )
24 import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity )
26 import SrcLoc ( Located(..), SrcSpan, unLoc )
27 import Util ( sortLe )
28 import Var ( TyVar, DictId, Id, Var )
29 import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
32 %************************************************************************
34 \subsection{Bindings: @BindGroup@}
36 %************************************************************************
38 Global bindings (where clauses)
41 data HsLocalBinds id -- Bindings in a 'let' expression
42 -- or a 'where' clause
43 = HsValBinds (HsValBinds id)
44 | HsIPBinds (HsIPBinds id)
48 data HsValBinds id -- Value bindings (not implicit parameters)
49 = ValBindsIn -- Before typechecking
50 (LHsBinds id) [LSig id] -- Not dependency analysed
51 -- Recursive by default
53 | ValBindsOut -- After renaming
54 [(RecFlag, LHsBinds id)] -- Dependency analysed
57 type LHsBinds id = Bag (LHsBind id)
58 type DictBinds id = LHsBinds id -- Used for dictionary or method bindings
59 type LHsBind id = Located (HsBind id)
62 = FunBind { -- FunBind is used for both functions f x = e
63 -- and variables f = \x -> e
64 -- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds
66 -- Reason 2: instance decls can only have FunBinds, which is convenient
67 -- If you change this, you'll need tochange e.g. rnMethodBinds
69 -- But note that the form f :: a->a = ...
70 -- parses as a pattern binding, just like
71 -- (f :: a -> a) = ...
75 fun_infix :: Bool, -- True => infix declaration
77 fun_matches :: MatchGroup id, -- The payload
79 fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of
81 -- f :: Int -> forall a. a -> a
83 -- Then the MatchGroup will have type (Int -> a' -> a')
84 -- (with a free type variable a'). The coercion will take
85 -- a CoreExpr of this type and convert it to a CoreExpr of
86 -- type Int -> forall a'. a' -> a'
87 -- Notice that the coercion captures the free a'. That's
88 -- why coercions are (CoreExpr -> CoreExpr), rather than
89 -- just CoreExpr (with a functional type)
91 bind_fvs :: NameSet -- After the renamer, this contains a superset of the
92 -- Names of the other binders in this binding group that
93 -- are free in the RHS of the defn
94 -- Before renaming, and after typechecking,
95 -- the field is unused; it's just an error thunk
98 | PatBind { -- The pattern is never a simple variable;
99 -- That case is done by FunBind
102 pat_rhs_ty :: PostTcType, -- Type of the GRHSs
103 bind_fvs :: NameSet -- Same as for FunBind
106 | VarBind { -- Dictionary binding and suchlike
107 var_id :: id, -- All VarBinds are introduced by the type checker
108 var_rhs :: LHsExpr id -- Located only for consistency
111 | AbsBinds { -- Binds abstraction; TRANSLATION
113 abs_dicts :: [DictId],
114 abs_exports :: [([TyVar], id, id, [Prag])], -- (tvs, poly_id, mono_id, prags)
115 abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings
116 -- mixed up together; you can tell the dict bindings because
117 -- they are all VarBinds
119 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
121 -- Creates bindings for (polymorphic, overloaded) poly_f
122 -- in terms of monomorphic, non-overloaded mono_f
125 -- 1. 'binds' binds mono_f
126 -- 2. ftvs is a subset of tvs
127 -- 3. ftvs includes all tyvars free in ds
129 -- See section 9 of static semantics paper for more details.
130 -- (You can get a PhD for explaining the True Meaning
131 -- of this last construct.)
133 placeHolderNames :: NameSet
134 -- Used for the NameSet in FunBind and PatBind prior to the renamer
135 placeHolderNames = panic "placeHolderNames"
138 instance OutputableBndr id => Outputable (HsLocalBinds id) where
139 ppr (HsValBinds bs) = ppr bs
140 ppr (HsIPBinds bs) = ppr bs
141 ppr EmptyLocalBinds = empty
143 instance OutputableBndr id => Outputable (HsValBinds id) where
144 ppr (ValBindsIn binds sigs)
145 = pprValBindsForUser binds sigs
147 ppr (ValBindsOut sccs sigs)
148 = getPprStyle $ \ sty ->
149 if debugStyle sty then -- Print with sccs showing
150 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
152 pprValBindsForUser (unionManyBags (map snd sccs)) sigs
154 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
155 pp_rec Recursive = ptext SLIT("rec")
156 pp_rec NonRecursive = ptext SLIT("nonrec")
158 -- *not* pprLHsBinds because we don't want braces; 'let' and
159 -- 'where' include a list of HsBindGroups and we don't want
160 -- several groups of bindings each with braces around.
161 -- Sort by location before printing
162 pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2)
163 => LHsBinds id1 -> [LSig id2] -> SDoc
164 pprValBindsForUser binds sigs
165 = vcat (map snd (sort_by_loc decls))
168 decls :: [(SrcSpan, SDoc)]
169 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
170 [(loc, ppr bind) | L loc bind <- bagToList binds]
172 sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
174 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
176 | isEmptyLHsBinds binds = empty
177 | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
180 emptyLocalBinds :: HsLocalBinds a
181 emptyLocalBinds = EmptyLocalBinds
183 isEmptyLocalBinds :: HsLocalBinds a -> Bool
184 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
185 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
186 isEmptyLocalBinds EmptyLocalBinds = True
188 isEmptyValBinds :: HsValBinds a -> Bool
189 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
190 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
192 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
193 emptyValBindsIn = ValBindsIn emptyBag []
194 emptyValBindsOut = ValBindsOut [] []
196 emptyLHsBinds :: LHsBinds id
197 emptyLHsBinds = emptyBag
199 isEmptyLHsBinds :: LHsBinds id -> Bool
200 isEmptyLHsBinds = isEmptyBag
203 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
204 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
205 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
206 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
207 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
219 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
222 gp = ...same again, with gm instead of fm
224 This is a pretty bad translation, because it duplicates all the bindings.
225 So the desugarer tries to do a better job:
227 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
231 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
235 instance OutputableBndr id => Outputable (HsBind id) where
236 ppr mbind = ppr_monobind mbind
238 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
240 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
241 ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
242 ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
243 -- ToDo: print infix if appropriate
245 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
246 abs_exports = exports, abs_binds = val_binds })
247 = sep [ptext SLIT("AbsBinds"),
248 brackets (interpp'SP tyvars),
249 brackets (interpp'SP dictvars),
250 brackets (sep (punctuate comma (map ppr_exp exports)))]
252 nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
253 -- Print type signatures
254 $$ pprLHsBinds val_binds )
256 ppr_exp (tvs, gbl, lcl, prags)
257 = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
258 nest 2 (vcat (map (pprPrag gbl) prags))]
261 %************************************************************************
263 Implicit parameter bindings
265 %************************************************************************
271 (DictBinds id) -- Only in typechecker output; binds
272 -- uses of the implicit parameters
274 isEmptyIPBinds :: HsIPBinds id -> Bool
275 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
277 type LIPBind id = Located (IPBind id)
279 -- | Implicit parameter bindings.
285 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
286 ppr (IPBinds bs ds) = vcat (map ppr bs)
289 instance (OutputableBndr id) => Outputable (IPBind id) where
290 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
294 %************************************************************************
296 \subsection{Coercion functions}
298 %************************************************************************
301 -- A ExprCoFn is an expression with a hole in it
302 -- We need coercions to have concrete form so that we can zonk them
305 = CoHole -- The identity coercion
307 | CoCompose ExprCoFn ExprCoFn -- (\a1..an. []) `CoCompose` (\x1..xn. [])
308 -- = (\a1..an \x1..xn. [])
310 | ExprCoFn Coercion -- A cast: [] `cast` co
311 -- Guaranteedn not the identity coercion
313 | CoApp Var -- [] x; the xi are dicts or coercions
314 | CoTyApp Type -- [] t
315 | CoLam Id -- \x. []; the xi are dicts or coercions
316 | CoTyLam TyVar -- \a. []
318 -- Non-empty bindings, so that the identity coercion
319 -- is always exactly CoHole
320 | CoLet (LHsBinds Id) -- let binds in []
321 -- (would be nicer to be core bindings)
323 instance Outputable ExprCoFn where
324 ppr co_fn = pprCoFn (ptext SLIT("<>")) co_fn
326 pprCoFn :: SDoc -> ExprCoFn -> SDoc
327 pprCoFn it CoHole = it
328 pprCoFn it (CoCompose f1 f2) = pprCoFn (pprCoFn it f2) f1
329 pprCoFn it (ExprCoFn co) = it <+> ptext SLIT("`cast`") <+> pprParendType co
330 pprCoFn it (CoApp id) = it <+> ppr id
331 pprCoFn it (CoTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty
332 pprCoFn it (CoLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it
333 pprCoFn it (CoTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it
334 pprCoFn it (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
336 (<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
339 c1 <.> c2 = c1 `CoCompose` c2
341 mkCoTyApps :: [Type] -> ExprCoFn
342 mkCoTyApps tys = mk_co_fn CoTyApp (reverse tys)
344 mkCoApps :: [Id] -> ExprCoFn
345 mkCoApps ids = mk_co_fn CoApp (reverse ids)
347 mkCoTyLams :: [TyVar] -> ExprCoFn
348 mkCoTyLams ids = mk_co_fn CoTyLam ids
350 mkCoLams :: [Id] -> ExprCoFn
351 mkCoLams ids = mk_co_fn CoLam ids
353 mk_co_fn :: (a -> ExprCoFn) -> [a] -> ExprCoFn
354 mk_co_fn f as = foldr (CoCompose . f) CoHole as
356 idCoercion :: ExprCoFn
359 isIdCoercion :: ExprCoFn -> Bool
360 isIdCoercion CoHole = True
361 isIdCoercion other = False
365 %************************************************************************
367 \subsection{@Sig@: type signatures and value-modifying user pragmas}
369 %************************************************************************
371 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
372 ``specialise this function to these four types...'') in with type
373 signatures. Then all the machinery to move them into place, etc.,
377 type LSig name = Located (Sig name)
380 = TypeSig (Located name) -- A bog-std type signature
383 | SpecSig (Located name) -- Specialise a function or datatype ...
384 (LHsType name) -- ... to these types
387 | InlineSig (Located name) -- Function name
390 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
391 -- current instance decl
393 | FixSig (FixitySig name) -- Fixity declaration
395 type LFixitySig name = Located (FixitySig name)
396 data FixitySig name = FixitySig (Located name) Fixity
398 -- A Prag conveys pragmas from the type checker to the desugarer
404 (HsExpr Id) -- An expression, of the given specialised type, which
405 PostTcType -- specialises the polymorphic function
406 [Id] -- Dicts mentioned free in the expression
407 InlineSpec -- Inlining spec for the specialised function
409 isInlinePrag (InlinePrag _) = True
410 isInlinePrag prag = False
412 isSpecPrag (SpecPrag _ _ _ _) = True
413 isSpecPrag prag = False
417 okBindSig :: NameSet -> LSig Name -> Bool
418 okBindSig ns sig = sigForThisGroup ns sig
420 okHsBootSig :: LSig Name -> Bool
421 okHsBootSig (L _ (TypeSig _ _)) = True
422 okHsBootSig (L _ (FixSig _)) = True
423 okHsBootSig sig = False
425 okClsDclSig :: LSig Name -> Bool
426 okClsDclSig (L _ (SpecInstSig _)) = False
427 okClsDclSig sig = True -- All others OK
429 okInstDclSig :: NameSet -> LSig Name -> Bool
430 okInstDclSig ns lsig@(L _ sig) = ok ns sig
432 ok ns (TypeSig _ _) = False
433 ok ns (FixSig _) = False
434 ok ns (SpecInstSig _) = True
435 ok ns sig = sigForThisGroup ns lsig
437 sigForThisGroup :: NameSet -> LSig Name -> Bool
438 sigForThisGroup ns sig
439 = case sigName sig of
441 Just n -> n `elemNameSet` ns
443 sigName :: LSig name -> Maybe name
444 sigName (L _ sig) = f sig
446 f (TypeSig n _) = Just (unLoc n)
447 f (SpecSig n _ _) = Just (unLoc n)
448 f (InlineSig n _) = Just (unLoc n)
449 f (FixSig (FixitySig n _)) = Just (unLoc n)
452 isFixityLSig :: LSig name -> Bool
453 isFixityLSig (L _ (FixSig {})) = True
454 isFixityLSig _ = False
456 isVanillaLSig :: LSig name -> Bool
457 isVanillaLSig (L _(TypeSig {})) = True
458 isVanillaLSig sig = False
460 isSpecLSig :: LSig name -> Bool
461 isSpecLSig (L _(SpecSig {})) = True
462 isSpecLSig sig = False
464 isSpecInstLSig (L _ (SpecInstSig {})) = True
465 isSpecInstLSig sig = False
467 isPragLSig :: LSig name -> Bool
468 -- Identifies pragmas
469 isPragLSig (L _ (SpecSig {})) = True
470 isPragLSig (L _ (InlineSig {})) = True
471 isPragLSig other = False
473 isInlineLSig :: LSig name -> Bool
474 -- Identifies inline pragmas
475 isInlineLSig (L _ (InlineSig {})) = True
476 isInlineLSig other = False
478 hsSigDoc (TypeSig {}) = ptext SLIT("type signature")
479 hsSigDoc (SpecSig {}) = ptext SLIT("SPECIALISE pragma")
480 hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma")
481 hsSigDoc (SpecInstSig {}) = ptext SLIT("SPECIALISE instance pragma")
482 hsSigDoc (FixSig {}) = ptext SLIT("fixity declaration")
485 Signature equality is used when checking for duplicate signatures
488 eqHsSig :: LSig Name -> LSig Name -> Bool
489 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
490 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
491 eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2)) = s1 == s2 && unLoc n1 == unLoc n2
492 -- For specialisations, we don't have equality over
493 -- HsType, so it's not convenient to spot duplicate
494 -- specialisations here. Check for this later, when we're in Type land
495 eqHsSig _other1 _other2 = False
499 instance (OutputableBndr name) => Outputable (Sig name) where
500 ppr sig = ppr_sig sig
502 ppr_sig :: OutputableBndr name => Sig name -> SDoc
503 ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty
504 ppr_sig (FixSig fix_sig) = ppr fix_sig
505 ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl)
506 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
507 ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
509 instance Outputable name => Outputable (FixitySig name) where
510 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
512 pragBrackets :: SDoc -> SDoc
513 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
515 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
516 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
518 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
519 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
521 pprPrag :: Outputable id => id -> Prag -> SDoc
522 pprPrag var (InlinePrag inl) = ppr inl <+> ppr var
523 pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl