2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
6 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
11 #include "HsVersions.h"
13 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
19 import HsTypes ( LHsType )
23 import NameSet ( NameSet, elemNameSet, nameSetToList )
24 import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity )
26 import SrcLoc ( Located(..), unLoc )
28 import Bag ( Bag, bagToList )
31 %************************************************************************
33 \subsection{Bindings: @BindGroup@}
35 %************************************************************************
37 Global bindings (where clauses)
41 = HsBindGroup -- A mutually recursive group
43 [LSig id] -- Empty on typechecker output, Type Signatures
47 [LIPBind id] -- Not allowed at top level
49 instance OutputableBndr id => Outputable (HsBindGroup id) where
50 ppr (HsBindGroup binds sigs is_rec)
53 vcat (map ppr (bagToList binds))
54 -- *not* pprLHsBinds because we don't want braces; 'let' and
55 -- 'where' include a list of HsBindGroups and we don't want
56 -- several groups of bindings each with braces around.
59 ppr_isrec = getPprStyle $ \ sty ->
60 if userStyle sty then empty else
62 Recursive -> ptext SLIT("{- rec -}")
63 NonRecursive -> ptext SLIT("{- nonrec -}")
65 ppr (HsIPBinds ipbinds)
66 = vcat (map ppr ipbinds)
68 -- -----------------------------------------------------------------------------
69 -- Implicit parameter bindings
71 type LIPBind id = Located (IPBind id)
73 -- | Implicit parameter bindings.
79 instance (OutputableBndr id) => Outputable (IPBind id) where
80 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
82 -- -----------------------------------------------------------------------------
84 type LHsBinds id = Bag (LHsBind id)
85 type LHsBind id = Located (HsBind id)
87 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
88 pprLHsBinds binds = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
91 = FunBind (Located id)
92 -- Used for both functions f x = e
93 -- and variables f = \x -> e
94 -- Reason: the Match stuff lets us have an optional
95 -- result type sig f :: a->a = ...mentions a...
97 -- This also means that instance decls can only have
98 -- FunBinds, so if you change this, you'll need to
99 -- change e.g. rnMethodBinds
100 Bool -- True => infix declaration
103 | PatBind (LPat id) -- The pattern is never a simple variable;
104 -- That case is done by FunBind
107 | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike;
108 -- located only for consistency
110 | AbsBinds -- Binds abstraction; TRANSLATION
111 [TyVar] -- Type variables
113 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
114 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
115 (LHsBinds id) -- The "business end"
117 -- Creates bindings for *new* (polymorphic, overloaded) locals
118 -- in terms of *old* (monomorphic, non-overloaded) ones.
120 -- See section 9 of static semantics paper for more details.
121 -- (You can get a PhD for explaining the True Meaning
122 -- of this last construct.)
134 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
137 gp = ...same again, with gm instead of fm
139 This is a pretty bad translation, because it duplicates all the bindings.
140 So the desugarer tries to do a better job:
142 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
146 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
150 instance OutputableBndr id => Outputable (HsBind id) where
151 ppr mbind = ppr_monobind mbind
153 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
155 ppr_monobind (PatBind pat grhss) = pprPatBind pat grhss
156 ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs)
157 ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
158 -- ToDo: print infix if appropriate
160 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
161 = sep [ptext SLIT("AbsBinds"),
162 brackets (interpp'SP tyvars),
163 brackets (interpp'SP dictvars),
164 brackets (sep (punctuate comma (map ppr exports))),
165 brackets (interpp'SP (nameSetToList inlines))]
167 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
168 -- Print type signatures
170 pprLHsBinds val_binds )
173 %************************************************************************
175 \subsection{@Sig@: type signatures and value-modifying user pragmas}
177 %************************************************************************
179 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
180 ``specialise this function to these four types...'') in with type
181 signatures. Then all the machinery to move them into place, etc.,
185 type LSig name = Located (Sig name)
188 = Sig (Located name) -- a bog-std type signature
191 | SpecSig (Located name) -- specialise a function or datatype ...
192 (LHsType name) -- ... to these types
194 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
195 (Located name) -- Function name
196 Activation -- When inlining is *active*
198 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
199 -- current instance decl
201 | FixSig (FixitySig name) -- Fixity declaration
203 type LFixitySig name = Located (FixitySig name)
204 data FixitySig name = FixitySig (Located name) Fixity
208 okBindSig :: NameSet -> LSig Name -> Bool
209 okBindSig ns sig = sigForThisGroup ns sig
211 okClsDclSig :: LSig Name -> Bool
212 okClsDclSig (L _ (SpecInstSig _)) = False
213 okClsDclSig sig = True -- All others OK
215 okInstDclSig :: NameSet -> LSig Name -> Bool
216 okInstDclSig ns lsig@(L _ sig) = ok ns sig
218 ok ns (Sig _ _) = False
219 ok ns (FixSig _) = False
220 ok ns (SpecInstSig _) = True
221 ok ns sig = sigForThisGroup ns lsig
223 sigForThisGroup :: NameSet -> LSig Name -> Bool
224 sigForThisGroup ns sig
225 = case sigName sig of
227 Just n -> n `elemNameSet` ns
229 sigName :: LSig name -> Maybe name
230 sigName (L _ sig) = f sig
232 f (Sig n _) = Just (unLoc n)
233 f (SpecSig n _) = Just (unLoc n)
234 f (InlineSig _ n _) = Just (unLoc n)
235 f (FixSig (FixitySig n _)) = Just (unLoc n)
238 isFixitySig :: Sig name -> Bool
239 isFixitySig (FixSig _) = True
240 isFixitySig _ = False
242 isPragSig :: Sig name -> Bool
243 -- Identifies pragmas
244 isPragSig (SpecSig _ _) = True
245 isPragSig (InlineSig _ _ _) = True
246 isPragSig (SpecInstSig _) = True
247 isPragSig other = False
249 hsSigDoc (Sig _ _) = ptext SLIT("type signature")
250 hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma")
251 hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma")
252 hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma")
253 hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma")
254 hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
257 Signature equality is used when checking for duplicate signatures
260 eqHsSig :: Sig Name -> Sig Name -> Bool
261 eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2
262 eqHsSig (Sig n1 _) (Sig n2 _) = unLoc n1 == unLoc n2
263 eqHsSig (InlineSig b1 n1 _) (InlineSig b2 n2 _) = b1 == b2 && unLoc n1 == unLoc n2
264 -- For specialisations, we don't have equality over
265 -- HsType, so it's not convenient to spot duplicate
266 -- specialisations here. Check for this later, when we're in Type land
267 eqHsSig _other1 _other2 = False
271 instance (OutputableBndr name) => Outputable (Sig name) where
272 ppr sig = ppr_sig sig
274 ppr_sig :: OutputableBndr name => Sig name -> SDoc
276 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
278 ppr_sig (SpecSig var ty)
279 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
280 nest 4 (ppr ty <+> text "#-}")
283 ppr_sig (InlineSig True var phase)
284 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
286 ppr_sig (InlineSig False var phase)
287 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
289 ppr_sig (SpecInstSig ty)
290 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
292 ppr_sig (FixSig fix_sig) = ppr fix_sig
294 instance Outputable name => Outputable (FixitySig name) where
295 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]