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,
14 MatchGroup, pprFunBind,
16 import {-# SOURCE #-} HsPat ( LPat )
18 import HsTypes ( LHsType, PostTcType )
20 import NameSet ( NameSet, elemNameSet, nameSetToList )
21 import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity )
23 import SrcLoc ( Located(..), unLoc )
25 import Bag ( Bag, emptyBag, isEmptyBag, bagToList )
28 %************************************************************************
30 \subsection{Bindings: @BindGroup@}
32 %************************************************************************
34 Global bindings (where clauses)
38 = HsBindGroup -- A mutually recursive group
40 [LSig id] -- Empty on typechecker output, Type Signatures
44 [LIPBind id] -- Not allowed at top level
46 instance OutputableBndr id => Outputable (HsBindGroup id) where
47 ppr (HsBindGroup binds sigs is_rec)
50 vcat (map ppr (bagToList binds))
51 -- *not* pprLHsBinds because we don't want braces; 'let' and
52 -- 'where' include a list of HsBindGroups and we don't want
53 -- several groups of bindings each with braces around.
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 DictBinds id = LHsBinds id -- Used for dictionary or method bindings
83 type LHsBind id = Located (HsBind id)
85 emptyLHsBinds :: LHsBinds id
86 emptyLHsBinds = emptyBag
88 isEmptyLHsBinds :: LHsBinds id -> Bool
89 isEmptyLHsBinds = isEmptyBag
91 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
93 | isEmptyLHsBinds binds = empty
94 | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
97 = FunBind (Located id)
98 -- Used for both functions f x = e
99 -- and variables f = \x -> e
100 -- Reason: the Match stuff lets us have an optional
101 -- result type sig f :: a->a = ...mentions a...
103 -- This also means that instance decls can only have
104 -- FunBinds, so if you change this, you'll need to
105 -- change e.g. rnMethodBinds
106 Bool -- True => infix declaration
109 | PatBind (LPat id) -- The pattern is never a simple variable;
110 -- That case is done by FunBind
112 PostTcType -- Type of the GRHSs
114 | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike;
115 -- located only for consistency
117 | AbsBinds -- Binds abstraction; TRANSLATION
118 [TyVar] -- Type variables
120 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
121 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
122 (LHsBinds id) -- The "business end"
124 -- Creates bindings for *new* (polymorphic, overloaded) locals
125 -- in terms of *old* (monomorphic, non-overloaded) ones.
127 -- See section 9 of static semantics paper for more details.
128 -- (You can get a PhD for explaining the True Meaning
129 -- of this last construct.)
141 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
144 gp = ...same again, with gm instead of fm
146 This is a pretty bad translation, because it duplicates all the bindings.
147 So the desugarer tries to do a better job:
149 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
153 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
157 instance OutputableBndr id => Outputable (HsBind id) where
158 ppr mbind = ppr_monobind mbind
160 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
162 ppr_monobind (PatBind pat grhss ty) = pprPatBind pat grhss
163 ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs)
164 ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
165 -- ToDo: print infix if appropriate
167 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
168 = sep [ptext SLIT("AbsBinds"),
169 brackets (interpp'SP tyvars),
170 brackets (interpp'SP dictvars),
171 brackets (sep (punctuate comma (map ppr exports))),
172 brackets (interpp'SP (nameSetToList inlines))]
174 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
175 -- Print type signatures
177 pprLHsBinds val_binds )
180 %************************************************************************
182 \subsection{@Sig@: type signatures and value-modifying user pragmas}
184 %************************************************************************
186 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
187 ``specialise this function to these four types...'') in with type
188 signatures. Then all the machinery to move them into place, etc.,
192 type LSig name = Located (Sig name)
195 = Sig (Located name) -- a bog-std type signature
198 | SpecSig (Located name) -- specialise a function or datatype ...
199 (LHsType name) -- ... to these types
201 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
202 (Located name) -- Function name
203 Activation -- When inlining is *active*
205 | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
206 -- current instance decl
208 | FixSig (FixitySig name) -- Fixity declaration
210 type LFixitySig name = Located (FixitySig name)
211 data FixitySig name = FixitySig (Located name) Fixity
215 okBindSig :: NameSet -> LSig Name -> Bool
216 okBindSig ns sig = sigForThisGroup ns sig
218 okClsDclSig :: LSig Name -> Bool
219 okClsDclSig (L _ (SpecInstSig _)) = False
220 okClsDclSig sig = True -- All others OK
222 okInstDclSig :: NameSet -> LSig Name -> Bool
223 okInstDclSig ns lsig@(L _ sig) = ok ns sig
225 ok ns (Sig _ _) = False
226 ok ns (FixSig _) = False
227 ok ns (SpecInstSig _) = True
228 ok ns sig = sigForThisGroup ns lsig
230 sigForThisGroup :: NameSet -> LSig Name -> Bool
231 sigForThisGroup ns sig
232 = case sigName sig of
234 Just n -> n `elemNameSet` ns
236 sigName :: LSig name -> Maybe name
237 sigName (L _ sig) = f sig
239 f (Sig n _) = Just (unLoc n)
240 f (SpecSig n _) = Just (unLoc n)
241 f (InlineSig _ n _) = Just (unLoc n)
242 f (FixSig (FixitySig n _)) = Just (unLoc n)
245 isFixityLSig :: LSig name -> Bool
246 isFixityLSig (L _ (FixSig _)) = True
247 isFixityLSig _ = False
249 isVanillaLSig :: LSig name -> Bool
250 isVanillaLSig (L _(Sig name _)) = True
251 isVanillaLSig sig = False
253 isPragLSig :: LSig name -> Bool
254 -- Identifies pragmas
255 isPragLSig (L _ (SpecSig _ _)) = True
256 isPragLSig (L _ (InlineSig _ _ _)) = True
257 isPragLSig (L _ (SpecInstSig _)) = True
258 isPragLSig other = False
260 hsSigDoc (Sig _ _) = ptext SLIT("type signature")
261 hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma")
262 hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma")
263 hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma")
264 hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma")
265 hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
268 Signature equality is used when checking for duplicate signatures
271 eqHsSig :: Sig Name -> Sig Name -> Bool
272 eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2
273 eqHsSig (Sig n1 _) (Sig n2 _) = unLoc n1 == unLoc n2
274 eqHsSig (InlineSig b1 n1 _) (InlineSig b2 n2 _) = b1 == b2 && unLoc n1 == unLoc n2
275 -- For specialisations, we don't have equality over
276 -- HsType, so it's not convenient to spot duplicate
277 -- specialisations here. Check for this later, when we're in Type land
278 eqHsSig _other1 _other2 = False
282 instance (OutputableBndr name) => Outputable (Sig name) where
283 ppr sig = ppr_sig sig
285 ppr_sig :: OutputableBndr name => Sig name -> SDoc
287 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
289 ppr_sig (SpecSig var ty)
290 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
291 nest 4 (ppr ty <+> text "#-}")
294 ppr_sig (InlineSig True var phase)
295 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
297 ppr_sig (InlineSig False var phase)
298 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
300 ppr_sig (SpecInstSig ty)
301 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
303 ppr_sig (FixSig fix_sig) = ppr fix_sig
305 instance Outputable name => Outputable (FixitySig name) where
306 ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]