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)] -- (old, new) 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.)
84 nullBinds :: HsBinds tyvar uvar id pat -> Bool
86 nullBinds EmptyBinds = True
87 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
88 nullBinds (SingleBind b) = nullBind b
89 nullBinds (BindWith b _) = nullBind b
90 nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
94 instance (Outputable pat, NamedThing id, Outputable id,
95 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
96 Outputable (HsBinds tyvar uvar id pat) where
98 ppr sty EmptyBinds = ppNil
99 ppr sty (ThenBinds binds1 binds2)
100 = ppAbove (ppr sty binds1) (ppr sty binds2)
101 ppr sty (SingleBind bind) = ppr sty bind
102 ppr sty (BindWith bind sigs)
103 = ppAbove (if null sigs
105 else ppAboves (map (ppr sty) sigs))
107 ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
108 = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
109 ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
110 ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
111 ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
112 (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
115 %************************************************************************
117 \subsection{@Sig@: type signatures and value-modifying user pragmas}
119 %************************************************************************
121 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
122 ``specialise this function to these four types...'') in with type
123 signatures. Then all the machinery to move them into place, etc.,
128 = Sig name -- a bog-std type signature
132 | ClassOpSig name -- class-op sigs have different pragmas
134 (ClassOpPragmas name) -- only interface ones have pragmas
137 | SpecSig name -- specialise a function or datatype ...
138 (HsType name) -- ... to these types
139 (Maybe name) -- ... maybe using this as the code for it
142 | InlineSig name -- INLINE f
145 | DeforestSig name -- Deforest using this function definition
149 name -- Associate the "name"d function with
150 FAST_STRING -- the compiler-builtin unfolding (known
151 SrcLoc -- by the String name)
155 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
156 ppr sty (Sig var ty _)
157 = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
160 ppr sty (ClassOpSig var ty pragmas _)
161 = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
162 4 (ppHang (ppr sty ty)
163 4 (ifnotPprForUser sty (ppr sty pragmas)))
165 ppr sty (DeforestSig var _)
166 = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var])
169 ppr sty (SpecSig var ty using _)
170 = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")])
171 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
173 pp_using Nothing = ppNil
174 pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
176 ppr sty (InlineSig var _)
177 = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")]
179 ppr sty (MagicUnfoldingSig var str _)
180 = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")]
183 %************************************************************************
185 \subsection{Binding: @Bind@}
187 %************************************************************************
190 data Bind tyvar uvar id pat -- binders and bindees
191 = EmptyBind -- because it's convenient when parsing signatures
192 | NonRecBind (MonoBinds tyvar uvar id pat)
193 | RecBind (MonoBinds tyvar uvar id pat)
197 nullBind :: Bind tyvar uvar id pat -> Bool
199 nullBind EmptyBind = True
200 nullBind (NonRecBind bs) = nullMonoBinds bs
201 nullBind (RecBind bs) = nullMonoBinds bs
205 bindIsRecursive :: Bind tyvar uvar id pat -> Bool
207 bindIsRecursive EmptyBind = False
208 bindIsRecursive (NonRecBind _) = False
209 bindIsRecursive (RecBind _) = True
213 instance (NamedThing id, Outputable id, Outputable pat,
214 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
215 Outputable (Bind tyvar uvar id pat) where
216 ppr sty EmptyBind = ppNil
217 ppr sty (NonRecBind binds)
218 = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
220 ppr sty (RecBind binds)
221 = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
225 %************************************************************************
227 \subsection{Bindings: @MonoBinds@}
229 %************************************************************************
231 Global bindings (where clauses)
234 data MonoBinds tyvar uvar id pat
236 | AndMonoBinds (MonoBinds tyvar uvar id pat)
237 (MonoBinds tyvar uvar id pat)
239 (GRHSsAndBinds tyvar uvar id pat)
242 Bool -- True => infix declaration
243 [Match tyvar uvar id pat] -- must have at least one Match
246 | VarMonoBind id -- TRANSLATION
247 (HsExpr tyvar uvar id pat)
249 | CoreMonoBind id -- TRANSLATION
250 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
254 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
256 nullMonoBinds EmptyMonoBinds = True
257 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
258 nullMonoBinds other_monobind = False
262 instance (NamedThing id, Outputable id, Outputable pat,
263 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
264 Outputable (MonoBinds tyvar uvar id pat) where
265 ppr sty EmptyMonoBinds = ppNil
266 ppr sty (AndMonoBinds binds1 binds2)
267 = ppAbove (ppr sty binds1) (ppr sty binds2)
269 ppr sty (PatMonoBind pat grhss_n_binds locn)
270 = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
272 ppr sty (FunMonoBind fun inf matches locn)
273 = pprMatches sty (False, pprNonSym sty fun) matches
274 -- ToDo: print infix if appropriate
276 ppr sty (VarMonoBind name expr)
277 = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
279 ppr sty (CoreMonoBind name expr)
280 = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
283 %************************************************************************
285 \subsection{Collecting binders from @HsBinds@}
287 %************************************************************************
289 Get all the binders in some @MonoBinds@, IN THE ORDER OF
290 APPEARANCE; e.g., in:
298 it should return @[x, y, f, a, b]@ (remember, order important).
301 collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
302 collectTopBinders EmptyBinds = emptyBag
303 collectTopBinders (SingleBind b) = collectBinders b
304 collectTopBinders (BindWith b _) = collectBinders b
305 collectTopBinders (ThenBinds b1 b2)
306 = collectTopBinders b1 `unionBags` collectTopBinders b2
308 collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
309 collectBinders EmptyBind = emptyBag
310 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
311 collectBinders (RecBind monobinds) = collectMonoBinders monobinds
313 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
314 collectMonoBinders EmptyMonoBinds = emptyBag
315 collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
316 collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
317 collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
318 collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
319 collectMonoBinders (AndMonoBinds bs1 bs2)
320 = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2