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 NameSet ( NameSet, nameSetToList )
24 import BasicTypes ( RecFlag(..), Fixity )
27 import SrcLoc ( SrcLoc )
31 %************************************************************************
33 \subsection{Bindings: @HsBinds@}
35 %************************************************************************
37 The following syntax may produce new syntax which is not part of the input,
38 and which is instead a translation of the input to the typechecker.
39 Syntax translations are marked TRANSLATION in comments. New empty
40 productions are useful in development but may not appear in the final
43 Collections of bindings, created by dependency analysis and translation:
46 data HsBinds id pat -- binders and bindees
49 | ThenBinds (HsBinds id pat)
52 | MonoBind (MonoBinds id pat)
53 [Sig id] -- Empty on typechecker output
58 nullBinds :: HsBinds id pat -> Bool
60 nullBinds EmptyBinds = True
61 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
62 nullBinds (MonoBind b _ _) = nullMonoBinds b
64 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
65 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
66 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
70 instance (Outputable pat, Outputable id) =>
71 Outputable (HsBinds id pat) where
72 ppr binds = ppr_binds binds
74 ppr_binds EmptyBinds = empty
75 ppr_binds (ThenBinds binds1 binds2)
76 = ($$) (ppr_binds binds1) (ppr_binds binds2)
77 ppr_binds (MonoBind bind sigs is_rec)
78 = vcat [ifNotPprForUser (ptext rec_str),
83 rec_str = case is_rec of
84 Recursive -> SLIT("{- rec -}")
85 NonRecursive -> SLIT("{- nonrec -}")
88 %************************************************************************
90 \subsection{Bindings: @MonoBinds@}
92 %************************************************************************
94 Global bindings (where clauses)
100 | AndMonoBinds (MonoBinds id pat)
108 Bool -- True => infix declaration
112 | VarMonoBind id -- TRANSLATION
115 | CoreMonoBind id -- TRANSLATION
116 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
118 | AbsBinds -- Binds abstraction; TRANSLATION
119 [TyVar] -- Type variables
121 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
122 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
123 (MonoBinds id pat) -- The "business end"
125 -- Creates bindings for *new* (polymorphic, overloaded) locals
126 -- in terms of *old* (monomorphic, non-overloaded) ones.
128 -- See section 9 of static semantics paper for more details.
129 -- (You can get a PhD for explaining the True Meaning
130 -- of this last construct.)
142 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
145 gp = ...same again, with gm instead of fm
147 This is a pretty bad translation, because it duplicates all the bindings.
148 So the desugarer tries to do a better job:
150 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
154 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
158 -- We keep the invariant that a MonoBinds is only empty
159 -- if it is exactly EmptyMonoBinds
161 nullMonoBinds :: MonoBinds id pat -> Bool
162 nullMonoBinds EmptyMonoBinds = True
163 nullMonoBinds other_monobind = False
165 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
166 andMonoBinds EmptyMonoBinds mb = mb
167 andMonoBinds mb EmptyMonoBinds = mb
168 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
170 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
171 andMonoBindList binds
174 loop1 [] = EmptyMonoBinds
175 loop1 (EmptyMonoBinds : binds) = loop1 binds
176 loop1 (b:bs) = loop2 b bs
180 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
181 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
185 instance (Outputable id, Outputable pat) =>
186 Outputable (MonoBinds id pat) where
187 ppr mbind = ppr_monobind mbind
190 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
191 ppr_monobind EmptyMonoBinds = empty
192 ppr_monobind (AndMonoBinds binds1 binds2)
193 = ppr_monobind binds1 $$ ppr_monobind binds2
195 ppr_monobind (PatMonoBind pat grhss locn)
196 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
198 ppr_monobind (FunMonoBind fun inf matches locn)
199 = pprMatches (False, ppr fun) matches
200 -- ToDo: print infix if appropriate
202 ppr_monobind (VarMonoBind name expr)
203 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
205 ppr_monobind (CoreMonoBind name expr)
206 = sep [ppr name <+> equals, nest 4 (ppr expr)]
208 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
209 = sep [ptext SLIT("AbsBinds"),
210 brackets (interpp'SP tyvars),
211 brackets (interpp'SP dictvars),
212 brackets (sep (punctuate comma (map ppr exports))),
213 brackets (interpp'SP (nameSetToList inlines))]
215 nest 4 (ppr val_binds)
218 %************************************************************************
220 \subsection{@Sig@: type signatures and value-modifying user pragmas}
222 %************************************************************************
224 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
225 ``specialise this function to these four types...'') in with type
226 signatures. Then all the machinery to move them into place, etc.,
231 = Sig name -- a bog-std type signature
235 | ClassOpSig name -- Selector name
236 name -- Default-method name (if any)
237 Bool -- True <=> there is an explicit, programmer-supplied
238 -- default declaration in the class decl
242 | SpecSig name -- specialise a function or datatype ...
243 (HsType name) -- ... to these types
246 | InlineSig name -- INLINE f
250 | NoInlineSig name -- NOINLINE f
254 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
255 -- current instance decl
258 | FixSig (FixitySig name) -- Fixity declaration
261 data FixitySig name = FixitySig name Fixity SrcLoc
265 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
267 = filter sig_for_me sigs
269 sig_for_me (Sig n _ _) = f n
270 sig_for_me (ClassOpSig n _ _ _ _) = f n
271 sig_for_me (SpecSig n _ _) = f n
272 sig_for_me (InlineSig n _ _) = f n
273 sig_for_me (NoInlineSig n _ _) = f n
274 sig_for_me (SpecInstSig _ _) = False
275 sig_for_me (FixSig (FixitySig n _ _)) = f n
277 isFixitySig :: Sig name -> Bool
278 isFixitySig (FixSig _) = True
279 isFixitySig _ = False
281 isClassOpSig :: Sig name -> Bool
282 isClassOpSig (ClassOpSig _ _ _ _ _) = True
283 isClassOpSig _ = False
285 isPragSig :: Sig name -> Bool
286 -- Identifies pragmas
287 isPragSig (SpecSig _ _ _) = True
288 isPragSig (InlineSig _ _ _) = True
289 isPragSig (NoInlineSig _ _ _) = True
290 isPragSig (SpecInstSig _ _) = True
291 isPragSig other = False
295 instance (Outputable name) => Outputable (Sig name) where
296 ppr sig = ppr_sig sig
298 instance Outputable name => Outputable (FixitySig name) where
299 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
302 ppr_sig (Sig var ty _)
303 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
305 ppr_sig (ClassOpSig var _ _ ty _)
306 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
308 ppr_sig (SpecSig var ty _)
309 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
310 nest 4 (ppr ty <+> text "#-}")
313 ppr_sig (InlineSig var phase _)
314 = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
316 ppr_sig (NoInlineSig var phase _)
317 = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
319 ppr_sig (SpecInstSig ty _)
320 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
322 ppr_sig (FixSig fix_sig) = ppr fix_sig
324 ppr_phase Nothing = empty
325 ppr_phase (Just n) = int n