2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
6 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
11 #include "HsVersions.h"
13 import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr )
14 import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
17 import HsTypes ( HsType )
18 import CoreSyn ( CoreExpr )
19 import PprCore () -- Instances for Outputable
23 import BasicTypes ( RecFlag(..), Fixity )
26 import SrcLoc ( SrcLoc )
30 %************************************************************************
32 \subsection{Bindings: @HsBinds@}
34 %************************************************************************
36 The following syntax may produce new syntax which is not part of the input,
37 and which is instead a translation of the input to the typechecker.
38 Syntax translations are marked TRANSLATION in comments. New empty
39 productions are useful in development but may not appear in the final
42 Collections of bindings, created by dependency analysis and translation:
45 data HsBinds id pat -- binders and bindees
48 | ThenBinds (HsBinds id pat)
51 | MonoBind (MonoBinds id pat)
52 [Sig id] -- Empty on typechecker output
57 nullBinds :: HsBinds id pat -> Bool
59 nullBinds EmptyBinds = True
60 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
61 nullBinds (MonoBind b _ _) = nullMonoBinds b
65 instance (Outputable pat, Outputable id) =>
66 Outputable (HsBinds id pat) where
67 ppr binds = ppr_binds binds
69 ppr_binds EmptyBinds = empty
70 ppr_binds (ThenBinds binds1 binds2)
71 = ($$) (ppr_binds binds1) (ppr_binds binds2)
72 ppr_binds (MonoBind bind sigs is_rec)
73 = vcat [ifNotPprForUser (ptext rec_str),
78 rec_str = case is_rec of
79 Recursive -> SLIT("{- rec -}")
80 NonRecursive -> SLIT("{- nonrec -}")
83 %************************************************************************
85 \subsection{Bindings: @MonoBinds@}
87 %************************************************************************
89 Global bindings (where clauses)
95 | AndMonoBinds (MonoBinds id pat)
103 Bool -- True => infix declaration
107 | VarMonoBind id -- TRANSLATION
110 | CoreMonoBind id -- TRANSLATION
111 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
113 | AbsBinds -- Binds abstraction; TRANSLATION
114 [TyVar] -- Type variables
116 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
117 (MonoBinds id pat) -- The "business end"
119 -- Creates bindings for *new* (polymorphic, overloaded) locals
120 -- in terms of *old* (monomorphic, non-overloaded) ones.
122 -- See section 9 of static semantics paper for more details.
123 -- (You can get a PhD for explaining the True Meaning
124 -- of this last construct.)
136 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
139 gp = ...same again, with gm instead of fm
141 This is a pretty bad translation, because it duplicates all the bindings.
142 So the desugarer tries to do a better job:
144 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
148 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
152 nullMonoBinds :: MonoBinds id pat -> Bool
154 nullMonoBinds EmptyMonoBinds = True
155 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
156 nullMonoBinds other_monobind = False
158 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
159 andMonoBinds EmptyMonoBinds mb = mb
160 andMonoBinds mb EmptyMonoBinds = mb
161 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
163 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
164 andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
168 instance (Outputable id, Outputable pat) =>
169 Outputable (MonoBinds id pat) where
170 ppr mbind = ppr_monobind mbind
173 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
174 ppr_monobind EmptyMonoBinds = empty
175 ppr_monobind (AndMonoBinds binds1 binds2)
176 = ppr_monobind binds1 $$ ppr_monobind binds2
178 ppr_monobind (PatMonoBind pat grhss locn)
179 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
181 ppr_monobind (FunMonoBind fun inf matches locn)
182 = pprMatches (False, ppr fun) matches
183 -- ToDo: print infix if appropriate
185 ppr_monobind (VarMonoBind name expr)
186 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
188 ppr_monobind (CoreMonoBind name expr)
189 = sep [ppr name <+> equals, nest 4 (ppr expr)]
191 ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
192 = sep [ptext SLIT("AbsBinds"),
193 brackets (interpp'SP tyvars),
194 brackets (interpp'SP dictvars),
195 brackets (interpp'SP exports)]
197 nest 4 (ppr val_binds)
200 %************************************************************************
202 \subsection{@Sig@: type signatures and value-modifying user pragmas}
204 %************************************************************************
206 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
207 ``specialise this function to these four types...'') in with type
208 signatures. Then all the machinery to move them into place, etc.,
213 = Sig name -- a bog-std type signature
217 | ClassOpSig name -- Selector name
218 (Maybe name) -- Default-method name (if any)
222 | SpecSig name -- specialise a function or datatype ...
223 (HsType name) -- ... to these types
224 (Maybe name) -- ... maybe using this as the code for it
227 | InlineSig name -- INLINE f
230 | NoInlineSig name -- NOINLINE f
233 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
234 -- current instance decl
237 | FixSig (FixitySig name) -- Fixity declaration
240 data FixitySig name = FixitySig name Fixity SrcLoc
244 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
246 = filter sig_for_me sigs
248 sig_for_me (Sig n _ _) = f n
249 sig_for_me (ClassOpSig n _ _ _) = f n
250 sig_for_me (SpecSig n _ _ _) = f n
251 sig_for_me (InlineSig n _) = f n
252 sig_for_me (NoInlineSig n _) = f n
253 sig_for_me (SpecInstSig _ _) = False
254 sig_for_me (FixSig (FixitySig n _ _)) = f n
256 nonFixitySigs :: [Sig name] -> [Sig name]
257 nonFixitySigs sigs = filter not_fix sigs
259 not_fix (FixSig _) = False
264 instance (Outputable name) => Outputable (Sig name) where
265 ppr sig = ppr_sig sig
267 instance Outputable name => Outputable (FixitySig name) where
268 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
271 ppr_sig (Sig var ty _)
272 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
274 ppr_sig (ClassOpSig var _ ty _)
275 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
277 ppr_sig (SpecSig var ty using _)
278 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
279 nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
282 pp_using Nothing = empty
283 pp_using (Just me) = hsep [char '=', ppr me]
285 ppr_sig (InlineSig var _)
286 = hsep [text "{-# INLINE", ppr var, text "#-}"]
288 ppr_sig (NoInlineSig var _)
289 = hsep [text "{-# NOINLINE", ppr var, text "#-}"]
291 ppr_sig (SpecInstSig ty _)
292 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
294 ppr_sig (FixSig fix_sig) = ppr fix_sig