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 ( HsExpr, pprExpr,
19 import HsTypes ( HsType )
23 import NameSet ( NameSet, elemNameSet, nameSetToList )
24 import BasicTypes ( RecFlag(..), Activation(..), Fixity, IPName )
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 -- binders and bindees
47 | ThenBinds (HsBinds id) (HsBinds id)
49 | MonoBind -- A mutually recursive group
51 [Sig id] -- Empty on typechecker output, Type Signatures
54 | IPBinds -- Implcit parameters
55 -- Not allowed at top level
56 [(IPName id, HsExpr id)]
60 nullBinds :: HsBinds id -> Bool
62 nullBinds EmptyBinds = True
63 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
64 nullBinds (MonoBind b _ _) = nullMonoBinds b
65 nullBinds (IPBinds b) = null b
67 mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
68 mkMonoBind _ EmptyMonoBinds = EmptyBinds
69 mkMonoBind is_rec mbinds = MonoBind mbinds [] is_rec
73 instance (OutputableBndr id) => Outputable (HsBinds id) where
74 ppr binds = ppr_binds binds
76 ppr_binds EmptyBinds = empty
77 ppr_binds (ThenBinds binds1 binds2)
78 = ppr_binds binds1 $$ ppr_binds binds2
80 ppr_binds (IPBinds binds)
81 = sep (punctuate semi (map pp_item binds))
83 pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs
85 ppr_binds (MonoBind bind sigs is_rec)
91 ppr_isrec = getPprStyle $ \ sty ->
92 if userStyle sty then empty else
94 Recursive -> ptext SLIT("{- rec -}")
95 NonRecursive -> ptext SLIT("{- nonrec -}")
98 %************************************************************************
100 \subsection{Bindings: @MonoBinds@}
102 %************************************************************************
104 Global bindings (where clauses)
110 | AndMonoBinds (MonoBinds id)
113 | FunMonoBind id -- Used for both functions f x = e
114 -- and variables f = \x -> e
115 -- Reason: the Match stuff lets us have an optional
116 -- result type sig f :: a->a = ...mentions a...
118 -- This also means that instance decls can only have
119 -- FunMonoBinds, so if you change this, you'll need to
120 -- change e.g. rnMethodBinds
121 Bool -- True => infix declaration
125 | PatMonoBind (Pat id) -- The pattern is never a simple variable;
126 -- That case is done by FunMonoBind
130 | VarMonoBind id -- TRANSLATION
133 | AbsBinds -- Binds abstraction; TRANSLATION
134 [TyVar] -- Type variables
136 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
137 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
138 (MonoBinds id) -- The "business end"
140 -- Creates bindings for *new* (polymorphic, overloaded) locals
141 -- in terms of *old* (monomorphic, non-overloaded) ones.
143 -- See section 9 of static semantics paper for more details.
144 -- (You can get a PhD for explaining the True Meaning
145 -- of this last construct.)
157 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
160 gp = ...same again, with gm instead of fm
162 This is a pretty bad translation, because it duplicates all the bindings.
163 So the desugarer tries to do a better job:
165 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
169 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
173 -- We keep the invariant that a MonoBinds is only empty
174 -- if it is exactly EmptyMonoBinds
176 nullMonoBinds :: MonoBinds id -> Bool
177 nullMonoBinds EmptyMonoBinds = True
178 nullMonoBinds other_monobind = False
180 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
181 andMonoBinds EmptyMonoBinds mb = mb
182 andMonoBinds mb EmptyMonoBinds = mb
183 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
185 andMonoBindList :: [MonoBinds id] -> MonoBinds id
186 andMonoBindList binds
189 loop1 [] = EmptyMonoBinds
190 loop1 (EmptyMonoBinds : binds) = loop1 binds
191 loop1 (b:bs) = loop2 b bs
195 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
196 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
201 instance OutputableBndr id => Outputable (MonoBinds id) where
202 ppr mbind = ppr_monobind mbind
205 ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
206 ppr_monobind EmptyMonoBinds = empty
207 ppr_monobind (AndMonoBinds binds1 binds2)
208 = ppr_monobind binds1 $$ ppr_monobind binds2
210 ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
211 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
212 -- ToDo: print infix if appropriate
214 ppr_monobind (VarMonoBind name expr)
215 = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
217 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
218 = sep [ptext SLIT("AbsBinds"),
219 brackets (interpp'SP tyvars),
220 brackets (interpp'SP dictvars),
221 brackets (sep (punctuate comma (map ppr exports))),
222 brackets (interpp'SP (nameSetToList inlines))]
224 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
225 -- Print type signatures
230 %************************************************************************
232 \subsection{@Sig@: type signatures and value-modifying user pragmas}
234 %************************************************************************
236 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
237 ``specialise this function to these four types...'') in with type
238 signatures. Then all the machinery to move them into place, etc.,
243 = Sig name -- a bog-std type signature
247 | SpecSig name -- specialise a function or datatype ...
248 (HsType name) -- ... to these types
251 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
252 name -- Function name
253 Activation -- When inlining is *active*
256 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
257 -- current instance decl
260 | FixSig (FixitySig name) -- Fixity declaration
262 data FixitySig name = FixitySig name Fixity SrcLoc
266 okBindSig :: NameSet -> Sig Name -> Bool
267 okBindSig ns sig = sigForThisGroup ns sig
269 okClsDclSig :: Sig Name -> Bool
270 okClsDclSig (SpecInstSig _ _) = False
271 okClsDclSig sig = True -- All others OK
273 okInstDclSig :: NameSet -> Sig Name -> Bool
274 okInstDclSig ns (Sig _ _ _) = False
275 okInstDclSig ns (FixSig _) = False
276 okInstDclSig ns (SpecInstSig _ _) = True
277 okInstDclSig ns sig = sigForThisGroup ns sig
279 sigForThisGroup :: NameSet -> Sig Name -> Bool
280 sigForThisGroup ns sig
281 = case sigName sig of
283 Just n -> n `elemNameSet` ns
285 sigName :: Sig name -> Maybe name
286 sigName (Sig n _ _) = Just n
287 sigName (SpecSig n _ _) = Just n
288 sigName (InlineSig _ n _ _) = Just n
289 sigName (FixSig (FixitySig n _ _)) = Just n
290 sigName other = Nothing
292 sigLoc :: Sig name -> SrcLoc
293 sigLoc (Sig _ _ loc) = loc
294 sigLoc (SpecSig _ _ loc) = loc
295 sigLoc (InlineSig _ _ _ loc) = loc
296 sigLoc (FixSig (FixitySig n _ loc)) = loc
297 sigLoc (SpecInstSig _ loc) = loc
299 isFixitySig :: Sig name -> Bool
300 isFixitySig (FixSig _) = True
301 isFixitySig _ = False
303 isPragSig :: Sig name -> Bool
304 -- Identifies pragmas
305 isPragSig (SpecSig _ _ _) = True
306 isPragSig (InlineSig _ _ _ _) = True
307 isPragSig (SpecInstSig _ _) = True
308 isPragSig other = False
310 hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc)
311 hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc)
312 hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc)
313 hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc)
314 hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),loc)
315 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
318 Signature equality is used when checking for duplicate signatures
321 eqHsSig :: Sig Name -> Sig Name -> Bool
322 eqHsSig (FixSig (FixitySig n1 _ _)) (FixSig (FixitySig n2 _ _)) = n1 == n2
323 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
324 eqHsSig (InlineSig b1 n1 _ _) (InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
325 -- For specialisations, we don't have equality over
326 -- HsType, so it's not convenient to spot duplicate
327 -- specialisations here. Check for this later, when we're in Type land
328 eqHsSig _other1 _other2 = False
332 instance (Outputable name) => Outputable (Sig name) where
333 ppr sig = ppr_sig sig
335 ppr_sig :: Outputable name => Sig name -> SDoc
336 ppr_sig (Sig var ty _)
337 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
339 ppr_sig (SpecSig var ty _)
340 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
341 nest 4 (ppr ty <+> text "#-}")
344 ppr_sig (InlineSig True var phase _)
345 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
347 ppr_sig (InlineSig False var phase _)
348 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
350 ppr_sig (SpecInstSig ty _)
351 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
353 ppr_sig (FixSig fix_sig) = ppr fix_sig
355 instance Outputable name => Outputable (FixitySig name) where
356 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]