2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
6 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
9 #include "HsVersions.h"
16 IMPORT_DELOOPER(HsLoop)
17 import HsMatches ( pprMatches, pprGRHSsAndBinds,
18 Match, GRHSsAndBinds )
19 import HsPat ( collectPatBinders, InPat )
20 import HsPragmas ( GenPragmas, ClassOpPragmas )
21 import HsTypes ( HsType )
22 import CoreSyn ( SYN_IE(CoreExpr) )
25 import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId )
26 import Name ( pprNonSym, getOccName, OccName )
27 import Outputable ( interpp'SP, ifnotPprForUser,
28 Outputable(..){-instance * (,)-}
30 import PprCore ( GenCoreExpr {- instance Outputable -} )
31 import PprType ( GenTyVar {- instance Outputable -} )
34 import SrcLoc ( SrcLoc{-instances-} )
35 import TyVar ( GenTyVar{-instances-} )
36 import Unique ( Unique {- instance Eq -} )
39 %************************************************************************
41 \subsection{Bindings: @HsBinds@}
43 %************************************************************************
45 The following syntax may produce new syntax which is not part of the input,
46 and which is instead a translation of the input to the typechecker.
47 Syntax translations are marked TRANSLATION in comments. New empty
48 productions are useful in development but may not appear in the final
51 Collections of bindings, created by dependency analysis and translation:
54 data HsBinds tyvar uvar id pat -- binders and bindees
57 | ThenBinds (HsBinds tyvar uvar id pat)
58 (HsBinds tyvar uvar id pat)
60 | SingleBind (Bind tyvar uvar id pat)
62 | BindWith -- Bind with a type signature.
63 -- These appear only on typechecker input
64 -- (HsType [in Sigs] can't appear on output)
65 (Bind tyvar uvar id pat)
68 | AbsBinds -- Binds abstraction; TRANSLATION
71 [(id, id)] -- (momonmorphic, polymorphic) pairs
72 [(id, HsExpr tyvar uvar id pat)] -- local dictionaries
73 (Bind tyvar uvar id pat) -- "the business end"
75 -- Creates bindings for *new* (polymorphic, overloaded) locals
76 -- in terms of *old* (monomorphic, non-overloaded) ones.
78 -- See section 9 of static semantics paper for more details.
79 -- (You can get a PhD for explaining the True Meaning
80 -- of this last construct.)
93 fp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
96 gp = ...same again, with gm instead of fm
98 This is a pretty bad translation, because it duplicates all the bindings.
99 So the desugarer tries to do a better job:
101 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
105 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
109 nullBinds :: HsBinds tyvar uvar id pat -> Bool
111 nullBinds EmptyBinds = True
112 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
113 nullBinds (SingleBind b) = nullBind b
114 nullBinds (BindWith b _) = nullBind b
115 nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
119 instance (Outputable pat, NamedThing id, Outputable id,
120 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
121 Outputable (HsBinds tyvar uvar id pat) where
123 ppr sty EmptyBinds = ppNil
124 ppr sty (ThenBinds binds1 binds2)
125 = ppAbove (ppr sty binds1) (ppr sty binds2)
126 ppr sty (SingleBind bind) = ppr sty bind
127 ppr sty (BindWith bind sigs)
128 = ppAbove (if null sigs
130 else ppAboves (map (ppr sty) sigs))
132 ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
133 = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
134 ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
135 ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
136 ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
137 (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
140 %************************************************************************
142 \subsection{@Sig@: type signatures and value-modifying user pragmas}
144 %************************************************************************
146 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
147 ``specialise this function to these four types...'') in with type
148 signatures. Then all the machinery to move them into place, etc.,
153 = Sig name -- a bog-std type signature
157 | ClassOpSig name -- Selector name
158 name -- Default-method name
162 | SpecSig name -- specialise a function or datatype ...
163 (HsType name) -- ... to these types
164 (Maybe name) -- ... maybe using this as the code for it
167 | InlineSig name -- INLINE f
170 | DeforestSig name -- Deforest using this function definition
174 name -- Associate the "name"d function with
175 FAST_STRING -- the compiler-builtin unfolding (known
176 SrcLoc -- by the String name)
180 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
181 ppr sty (Sig var ty _)
182 = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
185 ppr sty (ClassOpSig var _ ty _)
186 = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
189 ppr sty (DeforestSig var _)
190 = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var])
193 ppr sty (SpecSig var ty using _)
194 = ppHang (ppCat [ppStr "{-# SPECIALIZE", pprNonSym sty var, ppPStr SLIT("::")])
195 4 (ppCat [ppr sty ty, pp_using using, ppStr "#-}"])
198 pp_using Nothing = ppNil
199 pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
201 ppr sty (InlineSig var _)
203 = ppCat [ppStr "{-# INLINE", pprNonSym sty var, ppStr "#-}"]
205 ppr sty (MagicUnfoldingSig var str _)
206 = ppCat [ppStr "{-# MAGIC_UNFOLDING", pprNonSym sty var, ppPStr str, ppStr "#-}"]
209 %************************************************************************
211 \subsection{Binding: @Bind@}
213 %************************************************************************
216 data Bind tyvar uvar id pat -- binders and bindees
217 = EmptyBind -- because it's convenient when parsing signatures
218 | NonRecBind (MonoBinds tyvar uvar id pat)
219 | RecBind (MonoBinds tyvar uvar id pat)
223 nullBind :: Bind tyvar uvar id pat -> Bool
225 nullBind EmptyBind = True
226 nullBind (NonRecBind bs) = nullMonoBinds bs
227 nullBind (RecBind bs) = nullMonoBinds bs
231 bindIsRecursive :: Bind tyvar uvar id pat -> Bool
233 bindIsRecursive EmptyBind = False
234 bindIsRecursive (NonRecBind _) = False
235 bindIsRecursive (RecBind _) = True
239 instance (NamedThing id, Outputable id, Outputable pat,
240 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
241 Outputable (Bind tyvar uvar id pat) where
242 ppr sty EmptyBind = ppNil
243 ppr sty (NonRecBind binds)
244 = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- nonrec -}")))
246 ppr sty (RecBind binds)
247 = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- rec -}")))
251 %************************************************************************
253 \subsection{Bindings: @MonoBinds@}
255 %************************************************************************
257 Global bindings (where clauses)
260 data MonoBinds tyvar uvar id pat
262 | AndMonoBinds (MonoBinds tyvar uvar id pat)
263 (MonoBinds tyvar uvar id pat)
265 (GRHSsAndBinds tyvar uvar id pat)
268 Bool -- True => infix declaration
269 [Match tyvar uvar id pat] -- must have at least one Match
272 | VarMonoBind id -- TRANSLATION
273 (HsExpr tyvar uvar id pat)
275 | CoreMonoBind id -- TRANSLATION
276 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
280 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
282 nullMonoBinds EmptyMonoBinds = True
283 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
284 nullMonoBinds other_monobind = False
288 instance (NamedThing id, Outputable id, Outputable pat,
289 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
290 Outputable (MonoBinds tyvar uvar id pat) where
291 ppr sty EmptyMonoBinds = ppNil
292 ppr sty (AndMonoBinds binds1 binds2)
293 = ppAbove (ppr sty binds1) (ppr sty binds2)
295 ppr sty (PatMonoBind pat grhss_n_binds locn)
296 = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
298 ppr sty (FunMonoBind fun inf matches locn)
299 = pprMatches sty (False, ppr sty fun) matches
300 -- ToDo: print infix if appropriate
302 ppr sty (VarMonoBind name expr)
303 = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr)
305 ppr sty (CoreMonoBind name expr)
306 = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr)
309 %************************************************************************
311 \subsection{Collecting binders from @HsBinds@}
313 %************************************************************************
315 Get all the binders in some @MonoBinds@, IN THE ORDER OF
316 APPEARANCE; e.g., in:
324 it should return @[x, y, f, a, b]@ (remember, order important).
327 collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
328 collectTopBinders EmptyBinds = emptyBag
329 collectTopBinders (SingleBind b) = collectBinders b
330 collectTopBinders (BindWith b _) = collectBinders b
331 collectTopBinders (ThenBinds b1 b2)
332 = collectTopBinders b1 `unionBags` collectTopBinders b2
334 collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
335 collectBinders EmptyBind = emptyBag
336 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
337 collectBinders (RecBind monobinds) = collectMonoBinders monobinds
339 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
340 collectMonoBinders EmptyMonoBinds = emptyBag
341 collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
342 collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
343 collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
344 collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
345 collectMonoBinders (AndMonoBinds bs1 bs2)
346 = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2