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"
18 import HsMatches ( pprMatches, pprGRHSsAndBinds,
21 import HsPat ( collectPatBinders, InPat )
22 import HsPragmas ( GenPragmas, ClassOpPragmas )
23 import HsTypes ( PolyType )
26 import Id ( DictVar(..), Id(..), GenId )
28 import PprType ( pprType )
30 import SrcLoc ( SrcLoc{-instances-} )
31 import TyVar ( GenTyVar{-instances-} )
34 %************************************************************************
36 \subsection{Bindings: @HsBinds@}
38 %************************************************************************
40 The following syntax may produce new syntax which is not part of the input,
41 and which is instead a translation of the input to the typechecker.
42 Syntax translations are marked TRANSLATION in comments. New empty
43 productions are useful in development but may not appear in the final
46 Collections of bindings, created by dependency analysis and translation:
49 data HsBinds tyvar uvar id pat -- binders and bindees
52 | ThenBinds (HsBinds tyvar uvar id pat)
53 (HsBinds tyvar uvar id pat)
55 | SingleBind (Bind tyvar uvar id pat)
57 | BindWith -- Bind with a type signature.
58 -- These appear only on typechecker input
59 -- (PolyType [in Sigs] can't appear on output)
60 (Bind tyvar uvar id pat)
63 | AbsBinds -- Binds abstraction; TRANSLATION
66 [(id, id)] -- (old, new) pairs
67 [(id, HsExpr tyvar uvar id pat)] -- local dictionaries
68 (Bind tyvar uvar id pat) -- "the business end"
70 -- Creates bindings for *new* (polymorphic, overloaded) locals
71 -- in terms of *old* (monomorphic, non-overloaded) ones.
73 -- See section 9 of static semantics paper for more details.
74 -- (You can get a PhD for explaining the True Meaning
75 -- of this last construct.)
79 nullBinds :: HsBinds tyvar uvar id pat -> Bool
81 nullBinds EmptyBinds = True
82 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
83 nullBinds (SingleBind b) = nullBind b
84 nullBinds (BindWith b _) = nullBind b
85 nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
89 instance (Outputable pat, NamedThing id, Outputable id,
90 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
91 Outputable (HsBinds tyvar uvar id pat) where
93 ppr sty EmptyBinds = ppNil
94 ppr sty (ThenBinds binds1 binds2)
95 = ppAbove (ppr sty binds1) (ppr sty binds2)
96 ppr sty (SingleBind bind) = ppr sty bind
97 ppr sty (BindWith bind sigs)
98 = ppAbove (if null sigs
100 else ppAboves (map (ppr sty) sigs))
102 ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
103 = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
104 ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
105 ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
106 ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
107 (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
110 %************************************************************************
112 \subsection{@Sig@: type signatures and value-modifying user pragmas}
114 %************************************************************************
116 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
117 ``specialise this function to these four types...'') in with type
118 signatures. Then all the machinery to move them into place, etc.,
123 = Sig name -- a bog-std type signature
125 (GenPragmas name) -- only interface ones have pragmas
128 | ClassOpSig name -- class-op sigs have different pragmas
130 (ClassOpPragmas name) -- only interface ones have pragmas
133 | SpecSig name -- specialise a function or datatype ...
134 (PolyType name) -- ... to these types
135 (Maybe name) -- ... maybe using this as the code for it
138 | InlineSig name -- INLINE f
141 -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
142 | DeforestSig name -- Deforest using this function definition
146 name -- Associate the "name"d function with
147 FAST_STRING -- the compiler-builtin unfolding (known
148 SrcLoc -- by the String name)
152 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
153 ppr sty (Sig var ty pragmas _)
154 = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
155 4 (ppHang (ppr sty ty)
156 4 (ifnotPprForUser sty (ppr sty pragmas)))
158 ppr sty (ClassOpSig var ty pragmas _)
159 = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
160 4 (ppHang (ppr sty ty)
161 4 (ifnotPprForUser sty (ppr sty pragmas)))
163 ppr sty (DeforestSig var _)
164 = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonOp sty var])
167 ppr sty (SpecSig var ty using _)
168 = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonOp sty var, ppPStr SLIT("::")])
169 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
171 pp_using Nothing = ppNil
172 pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
174 ppr sty (InlineSig var _)
175 = ppCat [ppPStr SLIT("{-# INLINE"), pprNonOp sty var, ppPStr SLIT("#-}")]
177 ppr sty (MagicUnfoldingSig var str _)
178 = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonOp sty var, ppPStr str, ppPStr SLIT("#-}")]
181 %************************************************************************
183 \subsection{Binding: @Bind@}
185 %************************************************************************
188 data Bind tyvar uvar id pat -- binders and bindees
189 = EmptyBind -- because it's convenient when parsing signatures
190 | NonRecBind (MonoBinds tyvar uvar id pat)
191 | RecBind (MonoBinds tyvar uvar id pat)
195 nullBind :: Bind tyvar uvar id pat -> Bool
197 nullBind EmptyBind = True
198 nullBind (NonRecBind bs) = nullMonoBinds bs
199 nullBind (RecBind bs) = nullMonoBinds bs
203 bindIsRecursive :: Bind tyvar uvar id pat -> Bool
205 bindIsRecursive EmptyBind = False
206 bindIsRecursive (NonRecBind _) = False
207 bindIsRecursive (RecBind _) = True
211 instance (NamedThing id, Outputable id, Outputable pat,
212 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
213 Outputable (Bind tyvar uvar id pat) where
214 ppr sty EmptyBind = ppNil
215 ppr sty (NonRecBind binds)
216 = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
218 ppr sty (RecBind binds)
219 = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
223 %************************************************************************
225 \subsection{Bindings: @MonoBinds@}
227 %************************************************************************
229 Global bindings (where clauses)
232 data MonoBinds tyvar uvar id pat
234 | AndMonoBinds (MonoBinds tyvar uvar id pat)
235 (MonoBinds tyvar uvar id pat)
237 (GRHSsAndBinds tyvar uvar id pat)
240 [Match tyvar uvar id pat] -- must have at least one Match
242 | VarMonoBind id -- TRANSLATION
243 (HsExpr tyvar uvar id pat)
247 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
249 nullMonoBinds EmptyMonoBinds = True
250 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
251 nullMonoBinds other_monobind = False
255 instance (NamedThing id, Outputable id, Outputable pat,
256 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
257 Outputable (MonoBinds tyvar uvar id pat) where
258 ppr sty EmptyMonoBinds = ppNil
259 ppr sty (AndMonoBinds binds1 binds2)
260 = ppAbove (ppr sty binds1) (ppr sty binds2)
262 ppr sty (PatMonoBind pat grhss_n_binds locn)
263 = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
265 ppr sty (FunMonoBind fun matches locn)
266 = pprMatches sty (False, pprNonOp sty fun) matches
268 ppr sty (VarMonoBind name expr)
269 = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
272 %************************************************************************
274 \subsection{Collecting binders from @HsBinds@}
276 %************************************************************************
278 Get all the binders in some @MonoBinds@, IN THE ORDER OF
279 APPEARANCE; e.g., in:
287 it should return @[x, y, f, a, b]@ (remember, order important).
290 collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
291 collectTopLevelBinders EmptyBinds = []
292 collectTopLevelBinders (SingleBind b) = collectBinders b
293 collectTopLevelBinders (BindWith b _) = collectBinders b
294 collectTopLevelBinders (ThenBinds b1 b2)
295 = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
297 collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
298 collectBinders EmptyBind = []
299 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
300 collectBinders (RecBind monobinds) = collectMonoBinders monobinds
302 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
303 collectMonoBinders EmptyMonoBinds = []
304 collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
305 collectMonoBinders (FunMonoBind f matches _) = [f]
306 collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
307 collectMonoBinders (AndMonoBinds bs1 bs2)
308 = collectMonoBinders bs1 ++ collectMonoBinders bs2
310 -- We'd like the binders -- and where they came from --
311 -- so we can make new ones with equally-useful origin info.
313 collectMonoBindersAndLocs
314 :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
316 collectMonoBindersAndLocs EmptyMonoBinds = []
318 collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
319 = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
321 collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
322 = collectPatBinders pat `zip` repeat locn
324 collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)]
327 collectMonoBindersAndLocs (VarMonoBind v expr)
328 = trace "collectMonoBindersAndLocs:VarMonoBind" []
329 -- ToDo: this is dubious, i.e., wrong, but harmless?