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 )
21 import NameSet ( NameSet, elemNameSet )
22 import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity )
24 import SrcLoc ( Located(..), SrcSpan, unLoc )
25 import Util ( sortLe )
26 import Var ( TyVar, DictId, Id )
27 import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
30 %************************************************************************
32 \subsection{Bindings: @BindGroup@}
34 %************************************************************************
36 Global bindings (where clauses)
39 data HsLocalBinds id -- Bindings in a 'let' expression
40 -- or a 'where' clause
41 = HsValBinds (HsValBinds id)
42 | HsIPBinds (HsIPBinds id)
46 data HsValBinds id -- Value bindings (not implicit parameters)
47 = ValBindsIn -- Before typechecking
48 (LHsBinds id) [LSig id] -- Not dependency analysed
49 -- Recursive by default
51 | ValBindsOut -- After renaming
52 [(RecFlag, LHsBinds id)] -- Dependency analysed
55 type LHsBinds id = Bag (LHsBind id)
56 type DictBinds id = LHsBinds id -- Used for dictionary or method bindings
57 type LHsBind id = Located (HsBind id)
60 = FunBind { -- FunBind is used for both functions f x = e
61 -- and variables f = \x -> e
62 -- Reason 1: the Match stuff lets us have an optional
63 -- result type sig f :: a->a = ...mentions a...
65 -- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds
67 -- Reason 3: instance decls can only have FunBinds, which is convenient
68 -- If you change this, you'll need tochange e.g. rnMethodBinds
72 fun_infix :: Bool, -- True => infix declaration
74 fun_matches :: MatchGroup id, -- The payload
76 fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of
78 -- f :: Int -> forall a. a -> a
80 -- Then the MatchGroup will have type (Int -> a' -> a')
81 -- (with a free type variable a'). The coercion will take
82 -- a CoreExpr of this type and convert it to a CoreExpr of
83 -- type Int -> forall a'. a' -> a'
84 -- Notice that the coercion captures the free a'. That's
85 -- why coercions are (CoreExpr -> CoreExpr), rather than
86 -- just CoreExpr (with a functional type)
88 bind_fvs :: NameSet -- After the renamer, this contains a superset of the
89 -- Names of the other binders in this binding group that
90 -- are free in the RHS of the defn
91 -- Before renaming, and after typechecking,
92 -- the field is unused; it's just an error thunk
95 | PatBind { -- The pattern is never a simple variable;
96 -- That case is done by FunBind
99 pat_rhs_ty :: PostTcType, -- Type of the GRHSs
100 bind_fvs :: NameSet -- Same as for FunBind
103 | VarBind { -- Dictionary binding and suchlike
104 var_id :: id, -- All VarBinds are introduced by the type checker
105 var_rhs :: LHsExpr id -- Located only for consistency
108 | AbsBinds { -- Binds abstraction; TRANSLATION
110 abs_dicts :: [DictId],
111 abs_exports :: [([TyVar], id, id, [Prag])], -- (tvs, poly_id, mono_id, prags)
112 abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings
113 -- mixed up together; you can tell the dict bindings because
114 -- they are all VarBinds
116 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
118 -- Creates bindings for (polymorphic, overloaded) poly_f
119 -- in terms of monomorphic, non-overloaded mono_f
122 -- 1. 'binds' binds mono_f
123 -- 2. ftvs is a subset of tvs
124 -- 3. ftvs includes all tyvars free in ds
126 -- See section 9 of static semantics paper for more details.
127 -- (You can get a PhD for explaining the True Meaning
128 -- of this last construct.)
130 placeHolderNames :: NameSet
131 -- Used for the NameSet in FunBind and PatBind prior to the renamer
132 placeHolderNames = panic "placeHolderNames"
135 instance OutputableBndr id => Outputable (HsLocalBinds id) where
136 ppr (HsValBinds bs) = ppr bs
137 ppr (HsIPBinds bs) = ppr bs
138 ppr EmptyLocalBinds = empty
140 instance OutputableBndr id => Outputable (HsValBinds id) where
141 ppr (ValBindsIn binds sigs)
142 = pprValBindsForUser binds sigs
144 ppr (ValBindsOut sccs sigs)
145 = getPprStyle $ \ sty ->
146 if debugStyle sty then -- Print with sccs showing
147 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
149 pprValBindsForUser (unionManyBags (map snd sccs)) sigs
151 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
152 pp_rec Recursive = ptext SLIT("rec")
153 pp_rec NonRecursive = ptext SLIT("nonrec")
155 -- *not* pprLHsBinds because we don't want braces; 'let' and
156 -- 'where' include a list of HsBindGroups and we don't want
157 -- several groups of bindings each with braces around.
158 -- Sort by location before printing
159 pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2)
160 => LHsBinds id1 -> [LSig id2] -> SDoc
161 pprValBindsForUser binds sigs
162 = vcat (map snd (sort_by_loc decls))
165 decls :: [(SrcSpan, SDoc)]
166 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
167 [(loc, ppr bind) | L loc bind <- bagToList binds]
169 sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
171 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
173 | isEmptyLHsBinds binds = empty
174 | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
177 emptyLocalBinds :: HsLocalBinds a
178 emptyLocalBinds = EmptyLocalBinds
180 isEmptyLocalBinds :: HsLocalBinds a -> Bool
181 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
182 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
183 isEmptyLocalBinds EmptyLocalBinds = True
185 isEmptyValBinds :: HsValBinds a -> Bool
186 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
187 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
189 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
190 emptyValBindsIn = ValBindsIn emptyBag []
191 emptyValBindsOut = ValBindsOut [] []
193 emptyLHsBinds :: LHsBinds id
194 emptyLHsBinds = emptyBag
196 isEmptyLHsBinds :: LHsBinds id -> Bool
197 isEmptyLHsBinds = isEmptyBag
200 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
201 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
202 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
203 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
204 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
216 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
219 gp = ...same again, with gm instead of fm
221 This is a pretty bad translation, because it duplicates all the bindings.
222 So the desugarer tries to do a better job:
224 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
228 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
232 instance OutputableBndr id => Outputable (HsBind id) where
233 ppr mbind = ppr_monobind mbind
235 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
237 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
238 ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
239 ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
240 -- ToDo: print infix if appropriate
242 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
243 abs_exports = exports, abs_binds = val_binds })
244 = sep [ptext SLIT("AbsBinds"),
245 brackets (interpp'SP tyvars),
246 brackets (interpp'SP dictvars),
247 brackets (sep (punctuate comma (map ppr_exp exports)))]
249 nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
250 -- Print type signatures
251 $$ pprLHsBinds val_binds )
253 ppr_exp (tvs, gbl, lcl, prags)
254 = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
255 nest 2 (vcat (map (pprPrag gbl) prags))]
258 %************************************************************************
260 Implicit parameter bindings
262 %************************************************************************
268 (DictBinds id) -- Only in typechecker output; binds
269 -- uses of the implicit parameters
271 isEmptyIPBinds :: HsIPBinds id -> Bool
272 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
274 type LIPBind id = Located (IPBind id)
276 -- | Implicit parameter bindings.
282 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
283 ppr (IPBinds bs ds) = vcat (map ppr bs)
286 instance (OutputableBndr id) => Outputable (IPBind id) where
287 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
291 %************************************************************************
293 \subsection{Coercion functions}
295 %************************************************************************
298 -- A Coercion is an expression with a hole in it
299 -- We need coercions to have concrete form so that we can zonk them
302 = CoHole -- The identity coercion
303 | CoCompose ExprCoFn ExprCoFn
304 | CoApps ExprCoFn [Id] -- Non-empty list
305 | CoTyApps ExprCoFn [Type] -- in all of these
306 | CoLams [Id] ExprCoFn -- so that the identity coercion
307 | CoTyLams [TyVar] ExprCoFn -- is just Hole
308 | CoLet (LHsBinds Id) ExprCoFn -- Would be nicer to be core bindings
310 (<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
313 idCoercion :: ExprCoFn
316 isIdCoercion :: ExprCoFn -> Bool
317 isIdCoercion CoHole = True
318 isIdCoercion other = False
322 %************************************************************************
324 \subsection{@Sig@: type signatures and value-modifying user pragmas}
326 %************************************************************************
328 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
329 ``specialise this function to these four types...'') in with type
330 signatures. Then all the machinery to move them into place, etc.,
334 type LSig name = Located (Sig name)
337 = TypeSig (Located name) -- A bog-std type signature
340 | SpecSig (Located name) -- Specialise a function or datatype ...
341 (LHsType name) -- ... to these types
344 | InlineSig (Located name) -- Function name
347 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
348 -- current instance decl
350 | FixSig (FixitySig name) -- Fixity declaration
352 type LFixitySig name = Located (FixitySig name)
353 data FixitySig name = FixitySig (Located name) Fixity
355 -- A Prag conveys pragmas from the type checker to the desugarer
361 (HsExpr Id) -- An expression, of the given specialised type, which
362 PostTcType -- specialises the polymorphic function
363 [Id] -- Dicts mentioned free in the expression
364 InlineSpec -- Inlining spec for the specialised function
366 isInlinePrag (InlinePrag _) = True
367 isInlinePrag prag = False
369 isSpecPrag (SpecPrag _ _ _ _) = True
370 isSpecPrag prag = False
374 okBindSig :: NameSet -> LSig Name -> Bool
375 okBindSig ns sig = sigForThisGroup ns sig
377 okHsBootSig :: LSig Name -> Bool
378 okHsBootSig (L _ (TypeSig _ _)) = True
379 okHsBootSig (L _ (FixSig _)) = True
380 okHsBootSig sig = False
382 okClsDclSig :: LSig Name -> Bool
383 okClsDclSig (L _ (SpecInstSig _)) = False
384 okClsDclSig sig = True -- All others OK
386 okInstDclSig :: NameSet -> LSig Name -> Bool
387 okInstDclSig ns lsig@(L _ sig) = ok ns sig
389 ok ns (TypeSig _ _) = False
390 ok ns (FixSig _) = False
391 ok ns (SpecInstSig _) = True
392 ok ns sig = sigForThisGroup ns lsig
394 sigForThisGroup :: NameSet -> LSig Name -> Bool
395 sigForThisGroup ns sig
396 = case sigName sig of
398 Just n -> n `elemNameSet` ns
400 sigName :: LSig name -> Maybe name
401 sigName (L _ sig) = f sig
403 f (TypeSig n _) = Just (unLoc n)
404 f (SpecSig n _ _) = Just (unLoc n)
405 f (InlineSig n _) = Just (unLoc n)
406 f (FixSig (FixitySig n _)) = Just (unLoc n)
409 isFixityLSig :: LSig name -> Bool
410 isFixityLSig (L _ (FixSig {})) = True
411 isFixityLSig _ = False
413 isVanillaLSig :: LSig name -> Bool
414 isVanillaLSig (L _(TypeSig {})) = True
415 isVanillaLSig sig = False
417 isSpecLSig :: LSig name -> Bool
418 isSpecLSig (L _(SpecSig {})) = True
419 isSpecLSig sig = False
421 isSpecInstLSig (L _ (SpecInstSig {})) = True
422 isSpecInstLSig sig = False
424 isPragLSig :: LSig name -> Bool
425 -- Identifies pragmas
426 isPragLSig (L _ (SpecSig {})) = True
427 isPragLSig (L _ (InlineSig {})) = True
428 isPragLSig other = False
430 isInlineLSig :: LSig name -> Bool
431 -- Identifies inline pragmas
432 isInlineLSig (L _ (InlineSig {})) = True
433 isInlineLSig other = False
435 hsSigDoc (TypeSig {}) = ptext SLIT("type signature")
436 hsSigDoc (SpecSig {}) = ptext SLIT("SPECIALISE pragma")
437 hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma")
438 hsSigDoc (SpecInstSig {}) = ptext SLIT("SPECIALISE instance pragma")
439 hsSigDoc (FixSig {}) = ptext SLIT("fixity declaration")
442 Signature equality is used when checking for duplicate signatures
445 eqHsSig :: LSig Name -> LSig Name -> Bool
446 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
447 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
448 eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2)) = s1 == s2 && unLoc n1 == unLoc n2
449 -- For specialisations, we don't have equality over
450 -- HsType, so it's not convenient to spot duplicate
451 -- specialisations here. Check for this later, when we're in Type land
452 eqHsSig _other1 _other2 = False
456 instance (OutputableBndr name) => Outputable (Sig name) where
457 ppr sig = ppr_sig sig
459 ppr_sig :: OutputableBndr name => Sig name -> SDoc
460 ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty
461 ppr_sig (FixSig fix_sig) = ppr fix_sig
462 ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl)
463 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
464 ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
466 instance Outputable name => Outputable (FixitySig name) where
467 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
469 pragBrackets :: SDoc -> SDoc
470 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
472 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
473 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
475 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
476 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
478 pprPrag :: Outputable id => id -> Prag -> SDoc
479 pprPrag var (InlinePrag inl) = ppr inl <+> ppr var
480 pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl