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))
56 ppr_isrec = getPprStyle $ \ sty ->
57 if userStyle sty then empty else
59 Recursive -> ptext SLIT("{- rec -}")
60 NonRecursive -> ptext SLIT("{- nonrec -}")
62 ppr (HsIPBinds ipbinds)
63 = vcat (map ppr ipbinds)
65 mkHsBindGroup :: RecFlag -> Bag (LHsBind id) -> HsBindGroup id
66 mkHsBindGroup is_rec mbinds = HsBindGroup mbinds [] is_rec
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)
88 = FunBind (Located id)
89 -- Used for both functions f x = e
90 -- and variables f = \x -> e
91 -- Reason: the Match stuff lets us have an optional
92 -- result type sig f :: a->a = ...mentions a...
94 -- This also means that instance decls can only have
95 -- FunBinds, so if you change this, you'll need to
96 -- change e.g. rnMethodBinds
97 Bool -- True => infix declaration
100 | PatBind (LPat id) -- The pattern is never a simple variable;
101 -- That case is done by FunBind
104 | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike;
105 -- located only for consistency
107 | AbsBinds -- Binds abstraction; TRANSLATION
108 [TyVar] -- Type variables
110 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
111 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
112 (LHsBinds id) -- The "business end"
114 -- Creates bindings for *new* (polymorphic, overloaded) locals
115 -- in terms of *old* (monomorphic, non-overloaded) ones.
117 -- See section 9 of static semantics paper for more details.
118 -- (You can get a PhD for explaining the True Meaning
119 -- of this last construct.)
131 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
134 gp = ...same again, with gm instead of fm
136 This is a pretty bad translation, because it duplicates all the bindings.
137 So the desugarer tries to do a better job:
139 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
143 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
147 instance OutputableBndr id => Outputable (HsBind id) where
148 ppr mbind = ppr_monobind mbind
150 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
152 ppr_monobind (PatBind pat grhss) = pprPatBind pat grhss
153 ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs)
154 ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
155 -- ToDo: print infix if appropriate
157 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
158 = sep [ptext SLIT("AbsBinds"),
159 brackets (interpp'SP tyvars),
160 brackets (interpp'SP dictvars),
161 brackets (sep (punctuate comma (map ppr exports))),
162 brackets (interpp'SP (nameSetToList inlines))]
164 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
165 -- Print type signatures
170 %************************************************************************
172 \subsection{@Sig@: type signatures and value-modifying user pragmas}
174 %************************************************************************
176 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
177 ``specialise this function to these four types...'') in with type
178 signatures. Then all the machinery to move them into place, etc.,
182 type LSig name = Located (Sig name)
185 = Sig (Located name) -- a bog-std type signature
188 | SpecSig (Located name) -- specialise a function or datatype ...
189 (LHsType name) -- ... to these types
191 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
192 (Located name) -- Function name
193 Activation -- When inlining is *active*
195 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
196 -- current instance decl
198 | FixSig (FixitySig name) -- Fixity declaration
200 type LFixitySig name = Located (FixitySig name)
201 data FixitySig name = FixitySig (Located name) Fixity
205 okBindSig :: NameSet -> LSig Name -> Bool
206 okBindSig ns sig = sigForThisGroup ns sig
208 okClsDclSig :: LSig Name -> Bool
209 okClsDclSig (L _ (SpecInstSig _)) = False
210 okClsDclSig sig = True -- All others OK
212 okInstDclSig :: NameSet -> LSig Name -> Bool
213 okInstDclSig ns lsig@(L _ sig) = ok ns sig
215 ok ns (Sig _ _) = False
216 ok ns (FixSig _) = False
217 ok ns (SpecInstSig _) = True
218 ok ns sig = sigForThisGroup ns lsig
220 sigForThisGroup :: NameSet -> LSig Name -> Bool
221 sigForThisGroup ns sig
222 = case sigName sig of
224 Just n -> n `elemNameSet` ns
226 sigName :: LSig name -> Maybe name
227 sigName (L _ sig) = f sig
229 f (Sig n _) = Just (unLoc n)
230 f (SpecSig n _) = Just (unLoc n)
231 f (InlineSig _ n _) = Just (unLoc n)
232 f (FixSig (FixitySig n _)) = Just (unLoc n)
235 isFixitySig :: Sig name -> Bool
236 isFixitySig (FixSig _) = True
237 isFixitySig _ = False
239 isPragSig :: Sig name -> Bool
240 -- Identifies pragmas
241 isPragSig (SpecSig _ _) = True
242 isPragSig (InlineSig _ _ _) = True
243 isPragSig (SpecInstSig _) = True
244 isPragSig other = False
246 hsSigDoc (Sig _ _) = ptext SLIT("type signature")
247 hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma")
248 hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma")
249 hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma")
250 hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma")
251 hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
254 Signature equality is used when checking for duplicate signatures
257 eqHsSig :: Sig Name -> Sig Name -> Bool
258 eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2
259 eqHsSig (Sig n1 _) (Sig n2 _) = unLoc n1 == unLoc n2
260 eqHsSig (InlineSig b1 n1 _) (InlineSig b2 n2 _) = b1 == b2 && unLoc n1 == unLoc n2
261 -- For specialisations, we don't have equality over
262 -- HsType, so it's not convenient to spot duplicate
263 -- specialisations here. Check for this later, when we're in Type land
264 eqHsSig _other1 _other2 = False
268 instance (Outputable name) => Outputable (Sig name) where
269 ppr sig = ppr_sig sig
271 ppr_sig :: Outputable name => Sig name -> SDoc
273 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
275 ppr_sig (SpecSig var ty)
276 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
277 nest 4 (ppr ty <+> text "#-}")
280 ppr_sig (InlineSig True var phase)
281 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
283 ppr_sig (InlineSig False var phase)
284 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
286 ppr_sig (SpecInstSig ty)
287 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
289 ppr_sig (FixSig fix_sig) = ppr fix_sig
291 instance Outputable name => Outputable (FixitySig name) where
292 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]