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 )
29 import SrcLoc ( SrcLoc{-instances-} )
30 --import TyVar ( GenTyVar{-instances-} )
33 %************************************************************************
35 \subsection{Bindings: @HsBinds@}
37 %************************************************************************
39 The following syntax may produce new syntax which is not part of the input,
40 and which is instead a translation of the input to the typechecker.
41 Syntax translations are marked TRANSLATION in comments. New empty
42 productions are useful in development but may not appear in the final
45 Collections of bindings, created by dependency analysis and translation:
48 data HsBinds tyvar uvar id pat -- binders and bindees
51 | ThenBinds (HsBinds tyvar uvar id pat)
52 (HsBinds tyvar uvar id pat)
54 | SingleBind (Bind tyvar uvar id pat)
56 | BindWith -- Bind with a type signature.
57 -- These appear only on typechecker input
58 -- (PolyType [in Sigs] can't appear on output)
59 (Bind tyvar uvar id pat)
62 | AbsBinds -- Binds abstraction; TRANSLATION
65 [(id, id)] -- (old, new) pairs
66 [(id, HsExpr tyvar uvar id pat)] -- local dictionaries
67 (Bind tyvar uvar id pat) -- "the business end"
69 -- Creates bindings for *new* (polymorphic, overloaded) locals
70 -- in terms of *old* (monomorphic, non-overloaded) ones.
72 -- See section 9 of static semantics paper for more details.
73 -- (You can get a PhD for explaining the True Meaning
74 -- of this last construct.)
78 nullBinds :: HsBinds tyvar uvar id pat -> Bool
80 nullBinds EmptyBinds = True
81 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
82 nullBinds (SingleBind b) = nullBind b
83 nullBinds (BindWith b _) = nullBind b
84 nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
88 instance (Outputable pat, NamedThing id, Outputable id,
89 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
90 Outputable (HsBinds tyvar uvar id pat) where
92 ppr sty EmptyBinds = ppNil
93 ppr sty (ThenBinds binds1 binds2)
94 = ppAbove (ppr sty binds1) (ppr sty binds2)
95 ppr sty (SingleBind bind) = ppr sty bind
96 ppr sty (BindWith bind sigs)
97 = ppAbove (if null sigs
99 else ppAboves (map (ppr sty) sigs))
101 ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
102 = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
103 ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
104 ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
105 ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
106 (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
109 %************************************************************************
111 \subsection{@Sig@: type signatures and value-modifying user pragmas}
113 %************************************************************************
115 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
116 ``specialise this function to these four types...'') in with type
117 signatures. Then all the machinery to move them into place, etc.,
122 = Sig name -- a bog-std type signature
124 (GenPragmas name) -- only interface ones have pragmas
127 | ClassOpSig name -- class-op sigs have different pragmas
129 (ClassOpPragmas name) -- only interface ones have pragmas
132 | SpecSig name -- specialise a function or datatype ...
133 (PolyType name) -- ... to these types
134 (Maybe name) -- ... maybe using this as the code for it
137 | InlineSig name -- INLINE f
140 -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
141 | DeforestSig name -- Deforest using this function definition
145 name -- Associate the "name"d function with
146 FAST_STRING -- the compiler-builtin unfolding (known
147 SrcLoc -- by the String name)
151 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
152 ppr sty (Sig var ty pragmas _)
153 = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
154 4 (ppHang (ppr sty ty)
155 4 (ifnotPprForUser sty (ppr sty pragmas)))
157 ppr sty (ClassOpSig var ty pragmas _)
158 = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
159 4 (ppHang (ppr sty ty)
160 4 (ifnotPprForUser sty (ppr sty pragmas)))
162 ppr sty (DeforestSig var _)
163 = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonOp sty var])
166 ppr sty (SpecSig var ty using _)
167 = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonOp sty var, ppPStr SLIT("::")])
168 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
170 pp_using Nothing = ppNil
171 pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
173 ppr sty (InlineSig var _)
174 = ppCat [ppPStr SLIT("{-# INLINE"), pprNonOp sty var, ppPStr SLIT("#-}")]
176 ppr sty (MagicUnfoldingSig var str _)
177 = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonOp sty var, ppPStr str, ppPStr SLIT("#-}")]
180 %************************************************************************
182 \subsection{Binding: @Bind@}
184 %************************************************************************
187 data Bind tyvar uvar id pat -- binders and bindees
188 = EmptyBind -- because it's convenient when parsing signatures
189 | NonRecBind (MonoBinds tyvar uvar id pat)
190 | RecBind (MonoBinds tyvar uvar id pat)
194 nullBind :: Bind tyvar uvar id pat -> Bool
196 nullBind EmptyBind = True
197 nullBind (NonRecBind bs) = nullMonoBinds bs
198 nullBind (RecBind bs) = nullMonoBinds bs
202 bindIsRecursive :: Bind tyvar uvar id pat -> Bool
204 bindIsRecursive EmptyBind = False
205 bindIsRecursive (NonRecBind _) = False
206 bindIsRecursive (RecBind _) = True
210 instance (NamedThing id, Outputable id, Outputable pat,
211 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
212 Outputable (Bind tyvar uvar id pat) where
213 ppr sty EmptyBind = ppNil
214 ppr sty (NonRecBind binds)
215 = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
217 ppr sty (RecBind binds)
218 = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
222 %************************************************************************
224 \subsection{Bindings: @MonoBinds@}
226 %************************************************************************
228 Global bindings (where clauses)
231 data MonoBinds tyvar uvar id pat
233 | AndMonoBinds (MonoBinds tyvar uvar id pat)
234 (MonoBinds tyvar uvar id pat)
236 (GRHSsAndBinds tyvar uvar id pat)
239 [Match tyvar uvar id pat] -- must have at least one Match
241 | VarMonoBind id -- TRANSLATION
242 (HsExpr tyvar uvar id pat)
246 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
248 nullMonoBinds EmptyMonoBinds = True
249 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
250 nullMonoBinds other_monobind = False
254 instance (NamedThing id, Outputable id, Outputable pat,
255 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
256 Outputable (MonoBinds tyvar uvar id pat) where
257 ppr sty EmptyMonoBinds = ppNil
258 ppr sty (AndMonoBinds binds1 binds2)
259 = ppAbove (ppr sty binds1) (ppr sty binds2)
261 ppr sty (PatMonoBind pat grhss_n_binds locn)
262 = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
264 ppr sty (FunMonoBind fun matches locn)
265 = pprMatches sty (False, pprNonOp sty fun) matches
267 ppr sty (VarMonoBind name expr)
268 = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
271 %************************************************************************
273 \subsection{Collecting binders from @HsBinds@}
275 %************************************************************************
277 Get all the binders in some @MonoBinds@, IN THE ORDER OF
278 APPEARANCE; e.g., in:
286 it should return @[x, y, f, a, b]@ (remember, order important).
289 collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
290 collectTopLevelBinders EmptyBinds = []
291 collectTopLevelBinders (SingleBind b) = collectBinders b
292 collectTopLevelBinders (BindWith b _) = collectBinders b
293 collectTopLevelBinders (ThenBinds b1 b2)
294 = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
296 collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
297 collectBinders EmptyBind = []
298 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
299 collectBinders (RecBind monobinds) = collectMonoBinders monobinds
301 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
302 collectMonoBinders EmptyMonoBinds = []
303 collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
304 collectMonoBinders (FunMonoBind f matches _) = [f]
305 collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
306 collectMonoBinders (AndMonoBinds bs1 bs2)
307 = collectMonoBinders bs1 ++ collectMonoBinders bs2
309 -- We'd like the binders -- and where they came from --
310 -- so we can make new ones with equally-useful origin info.
312 collectMonoBindersAndLocs
313 :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
315 collectMonoBindersAndLocs EmptyMonoBinds = []
317 collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
318 = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
320 collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
321 = collectPatBinders pat `zip` repeat locn
323 collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)]
326 collectMonoBindersAndLocs (VarMonoBind v expr)
327 = trace "collectMonoBindersAndLocs:VarMonoBind" []
328 -- ToDo: this is dubious, i.e., wrong, but harmless?