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 -- -----------------------------------------------------------------------------
66 -- Implicit parameter bindings
68 type LIPBind id = Located (IPBind id)
70 -- | Implicit parameter bindings.
76 instance (OutputableBndr id) => Outputable (IPBind id) where
77 ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
79 -- -----------------------------------------------------------------------------
81 type LHsBinds id = Bag (LHsBind id)
82 type LHsBind id = Located (HsBind id)
85 = FunBind (Located id)
86 -- Used for both functions f x = e
87 -- and variables f = \x -> e
88 -- Reason: the Match stuff lets us have an optional
89 -- result type sig f :: a->a = ...mentions a...
91 -- This also means that instance decls can only have
92 -- FunBinds, so if you change this, you'll need to
93 -- change e.g. rnMethodBinds
94 Bool -- True => infix declaration
97 | PatBind (LPat id) -- The pattern is never a simple variable;
98 -- That case is done by FunBind
101 | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike;
102 -- located only for consistency
104 | AbsBinds -- Binds abstraction; TRANSLATION
105 [TyVar] -- Type variables
107 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
108 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
109 (LHsBinds id) -- The "business end"
111 -- Creates bindings for *new* (polymorphic, overloaded) locals
112 -- in terms of *old* (monomorphic, non-overloaded) ones.
114 -- See section 9 of static semantics paper for more details.
115 -- (You can get a PhD for explaining the True Meaning
116 -- of this last construct.)
128 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
131 gp = ...same again, with gm instead of fm
133 This is a pretty bad translation, because it duplicates all the bindings.
134 So the desugarer tries to do a better job:
136 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
140 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
144 instance OutputableBndr id => Outputable (HsBind id) where
145 ppr mbind = ppr_monobind mbind
147 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
149 ppr_monobind (PatBind pat grhss) = pprPatBind pat grhss
150 ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs)
151 ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
152 -- ToDo: print infix if appropriate
154 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
155 = sep [ptext SLIT("AbsBinds"),
156 brackets (interpp'SP tyvars),
157 brackets (interpp'SP dictvars),
158 brackets (sep (punctuate comma (map ppr exports))),
159 brackets (interpp'SP (nameSetToList inlines))]
161 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
162 -- Print type signatures
167 %************************************************************************
169 \subsection{@Sig@: type signatures and value-modifying user pragmas}
171 %************************************************************************
173 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
174 ``specialise this function to these four types...'') in with type
175 signatures. Then all the machinery to move them into place, etc.,
179 type LSig name = Located (Sig name)
182 = Sig (Located name) -- a bog-std type signature
185 | SpecSig (Located name) -- specialise a function or datatype ...
186 (LHsType name) -- ... to these types
188 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
189 (Located name) -- Function name
190 Activation -- When inlining is *active*
192 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
193 -- current instance decl
195 | FixSig (FixitySig name) -- Fixity declaration
197 type LFixitySig name = Located (FixitySig name)
198 data FixitySig name = FixitySig (Located name) Fixity
202 okBindSig :: NameSet -> LSig Name -> Bool
203 okBindSig ns sig = sigForThisGroup ns sig
205 okClsDclSig :: LSig Name -> Bool
206 okClsDclSig (L _ (SpecInstSig _)) = False
207 okClsDclSig sig = True -- All others OK
209 okInstDclSig :: NameSet -> LSig Name -> Bool
210 okInstDclSig ns lsig@(L _ sig) = ok ns sig
212 ok ns (Sig _ _) = False
213 ok ns (FixSig _) = False
214 ok ns (SpecInstSig _) = True
215 ok ns sig = sigForThisGroup ns lsig
217 sigForThisGroup :: NameSet -> LSig Name -> Bool
218 sigForThisGroup ns sig
219 = case sigName sig of
221 Just n -> n `elemNameSet` ns
223 sigName :: LSig name -> Maybe name
224 sigName (L _ sig) = f sig
226 f (Sig n _) = Just (unLoc n)
227 f (SpecSig n _) = Just (unLoc n)
228 f (InlineSig _ n _) = Just (unLoc n)
229 f (FixSig (FixitySig n _)) = Just (unLoc n)
232 isFixitySig :: Sig name -> Bool
233 isFixitySig (FixSig _) = True
234 isFixitySig _ = False
236 isPragSig :: Sig name -> Bool
237 -- Identifies pragmas
238 isPragSig (SpecSig _ _) = True
239 isPragSig (InlineSig _ _ _) = True
240 isPragSig (SpecInstSig _) = True
241 isPragSig other = False
243 hsSigDoc (Sig _ _) = ptext SLIT("type signature")
244 hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma")
245 hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma")
246 hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma")
247 hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma")
248 hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
251 Signature equality is used when checking for duplicate signatures
254 eqHsSig :: Sig Name -> Sig Name -> Bool
255 eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2
256 eqHsSig (Sig n1 _) (Sig n2 _) = unLoc n1 == unLoc n2
257 eqHsSig (InlineSig b1 n1 _) (InlineSig b2 n2 _) = b1 == b2 && unLoc n1 == unLoc n2
258 -- For specialisations, we don't have equality over
259 -- HsType, so it's not convenient to spot duplicate
260 -- specialisations here. Check for this later, when we're in Type land
261 eqHsSig _other1 _other2 = False
265 instance (OutputableBndr name) => Outputable (Sig name) where
266 ppr sig = ppr_sig sig
268 ppr_sig :: OutputableBndr name => Sig name -> SDoc
270 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
272 ppr_sig (SpecSig var ty)
273 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
274 nest 4 (ppr ty <+> text "#-}")
277 ppr_sig (InlineSig True var phase)
278 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
280 ppr_sig (InlineSig False var phase)
281 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
283 ppr_sig (SpecInstSig ty)
284 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
286 ppr_sig (FixSig fix_sig) = ppr fix_sig
288 instance Outputable name => Outputable (FixitySig name) where
289 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]