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"
17 import HsMatches ( pprMatches, pprGRHSsAndBinds,
18 Match, GRHSsAndBinds )
19 import HsPat ( collectPatBinders, InPat )
20 import HsPragmas ( GenPragmas, ClassOpPragmas )
21 import HsTypes ( PolyType )
24 import Id ( DictVar(..), Id(..), GenId )
25 import Name ( pprNonOp )
26 import Outputable ( interpp'SP, ifnotPprForUser,
27 Outputable(..){-instance * (,)-}
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 Bool -- True => infix declaration
241 [Match tyvar uvar id pat] -- must have at least one Match
243 | VarMonoBind id -- TRANSLATION
244 (HsExpr tyvar uvar id pat)
248 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
250 nullMonoBinds EmptyMonoBinds = True
251 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
252 nullMonoBinds other_monobind = False
256 instance (NamedThing id, Outputable id, Outputable pat,
257 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
258 Outputable (MonoBinds tyvar uvar id pat) where
259 ppr sty EmptyMonoBinds = ppNil
260 ppr sty (AndMonoBinds binds1 binds2)
261 = ppAbove (ppr sty binds1) (ppr sty binds2)
263 ppr sty (PatMonoBind pat grhss_n_binds locn)
264 = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
266 ppr sty (FunMonoBind fun inf matches locn)
267 = pprMatches sty (False, pprNonOp sty fun) matches
268 -- ToDo: print infix if appropriate
270 ppr sty (VarMonoBind name expr)
271 = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
274 %************************************************************************
276 \subsection{Collecting binders from @HsBinds@}
278 %************************************************************************
280 Get all the binders in some @MonoBinds@, IN THE ORDER OF
281 APPEARANCE; e.g., in:
289 it should return @[x, y, f, a, b]@ (remember, order important).
292 collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
293 collectTopLevelBinders EmptyBinds = []
294 collectTopLevelBinders (SingleBind b) = collectBinders b
295 collectTopLevelBinders (BindWith b _) = collectBinders b
296 collectTopLevelBinders (ThenBinds b1 b2)
297 = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
299 collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
300 collectBinders EmptyBind = []
301 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
302 collectBinders (RecBind monobinds) = collectMonoBinders monobinds
304 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
305 collectMonoBinders EmptyMonoBinds = []
306 collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
307 collectMonoBinders (FunMonoBind f _ matches _) = [f]
308 collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
309 collectMonoBinders (AndMonoBinds bs1 bs2)
310 = collectMonoBinders bs1 ++ collectMonoBinders bs2
312 -- We'd like the binders -- and where they came from --
313 -- so we can make new ones with equally-useful origin info.
315 collectMonoBindersAndLocs
316 :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
318 collectMonoBindersAndLocs EmptyMonoBinds = []
320 collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
321 = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
323 collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
324 = collectPatBinders pat `zip` repeat locn
326 collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)]
329 collectMonoBindersAndLocs (VarMonoBind v expr)
330 = trace "collectMonoBindersAndLocs:VarMonoBind" []
331 -- ToDo: this is dubious, i.e., wrong, but harmless?