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,
18 import HsImpExp ( pprHsVar )
20 import HsTypes ( HsType )
21 import CoreSyn ( CoreExpr )
22 import PprCore ( {- instance Outputable (Expr a) -} )
26 import PrelNames ( isUnboundName )
27 import NameSet ( NameSet, elemNameSet, nameSetToList )
28 import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..) )
30 import SrcLoc ( SrcLoc )
32 import Class ( DefMeth (..) )
35 %************************************************************************
37 \subsection{Bindings: @HsBinds@}
39 %************************************************************************
41 The following syntax may produce new syntax which is not part of the input,
42 and which is instead a translation of the input to the typechecker.
43 Syntax translations are marked TRANSLATION in comments. New empty
44 productions are useful in development but may not appear in the final
47 Collections of bindings, created by dependency analysis and translation:
50 data HsBinds id -- binders and bindees
53 | ThenBinds (HsBinds id)
56 | MonoBind (MonoBinds id)
57 [Sig id] -- Empty on typechecker output, Type Signatures
62 nullBinds :: HsBinds id -> Bool
64 nullBinds EmptyBinds = True
65 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
66 nullBinds (MonoBind b _ _) = nullMonoBinds b
68 mkMonoBind :: MonoBinds id -> [Sig id] -> RecFlag -> HsBinds id
69 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
70 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
74 instance (OutputableBndr id) => Outputable (HsBinds id) where
75 ppr binds = ppr_binds binds
77 ppr_binds EmptyBinds = empty
78 ppr_binds (ThenBinds binds1 binds2)
79 = ppr_binds binds1 $$ ppr_binds binds2
80 ppr_binds (MonoBind bind sigs is_rec)
86 ppr_isrec = getPprStyle $ \ sty ->
87 if userStyle sty then empty else
89 Recursive -> ptext SLIT("{- rec -}")
90 NonRecursive -> ptext SLIT("{- nonrec -}")
93 %************************************************************************
95 \subsection{Bindings: @MonoBinds@}
97 %************************************************************************
99 Global bindings (where clauses)
105 | AndMonoBinds (MonoBinds id)
108 | FunMonoBind id -- Used for both functions f x = e
109 -- and variables f = \x -> e
110 -- Reason: the Match stuff lets us have an optional
111 -- result type sig f :: a->a = ...mentions a...
113 -- This also means that instance decls can only have
114 -- FunMonoBinds, so if you change this, you'll need to
115 -- change e.g. rnMethodBinds
116 Bool -- True => infix declaration
120 | PatMonoBind (Pat id) -- The pattern is never a simple variable;
121 -- That case is done by FunMonoBind
125 | VarMonoBind id -- TRANSLATION
128 | AbsBinds -- Binds abstraction; TRANSLATION
129 [TyVar] -- Type variables
131 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
132 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
133 (MonoBinds id) -- The "business end"
135 -- Creates bindings for *new* (polymorphic, overloaded) locals
136 -- in terms of *old* (monomorphic, non-overloaded) ones.
138 -- See section 9 of static semantics paper for more details.
139 -- (You can get a PhD for explaining the True Meaning
140 -- of this last construct.)
152 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
155 gp = ...same again, with gm instead of fm
157 This is a pretty bad translation, because it duplicates all the bindings.
158 So the desugarer tries to do a better job:
160 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
164 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
168 -- We keep the invariant that a MonoBinds is only empty
169 -- if it is exactly EmptyMonoBinds
171 nullMonoBinds :: MonoBinds id -> Bool
172 nullMonoBinds EmptyMonoBinds = True
173 nullMonoBinds other_monobind = False
175 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
176 andMonoBinds EmptyMonoBinds mb = mb
177 andMonoBinds mb EmptyMonoBinds = mb
178 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
180 andMonoBindList :: [MonoBinds id] -> MonoBinds id
181 andMonoBindList binds
184 loop1 [] = EmptyMonoBinds
185 loop1 (EmptyMonoBinds : binds) = loop1 binds
186 loop1 (b:bs) = loop2 b bs
190 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
191 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
196 instance OutputableBndr id => Outputable (MonoBinds id) where
197 ppr mbind = ppr_monobind mbind
200 ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
201 ppr_monobind EmptyMonoBinds = empty
202 ppr_monobind (AndMonoBinds binds1 binds2)
203 = ppr_monobind binds1 $$ ppr_monobind binds2
205 ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
206 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
207 -- ToDo: print infix if appropriate
209 ppr_monobind (VarMonoBind name expr)
210 = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
212 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
213 = sep [ptext SLIT("AbsBinds"),
214 brackets (interpp'SP tyvars),
215 brackets (interpp'SP dictvars),
216 brackets (sep (punctuate comma (map ppr exports))),
217 brackets (interpp'SP (nameSetToList inlines))]
219 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
220 -- Print type signatures
225 %************************************************************************
227 \subsection{@Sig@: type signatures and value-modifying user pragmas}
229 %************************************************************************
231 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
232 ``specialise this function to these four types...'') in with type
233 signatures. Then all the machinery to move them into place, etc.,
238 = Sig name -- a bog-std type signature
242 | ClassOpSig name -- Selector name
243 (DefMeth name) -- Default-method info
244 -- See "THE NAMING STORY" in HsDecls
248 | SpecSig name -- specialise a function or datatype ...
249 (HsType name) -- ... to these types
252 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
253 name -- Function name
254 Activation -- When inlining is *active*
257 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
258 -- current instance decl
261 | FixSig (FixitySig name) -- Fixity declaration
265 okBindSig :: NameSet -> Sig Name -> Bool
266 okBindSig ns (ClassOpSig _ _ _ _) = False
267 okBindSig ns sig = sigForThisGroup ns sig
269 okClsDclSig :: NameSet -> Sig Name -> Bool
270 okClsDclSig ns (Sig _ _ _) = False
271 okClsDclSig ns sig = sigForThisGroup ns sig
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 ns sig
280 = case sigName sig of
282 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
283 | otherwise -> n `elemNameSet` ns
285 sigName :: Sig name -> Maybe name
286 sigName (Sig n _ _) = Just n
287 sigName (ClassOpSig n _ _ _) = Just n
288 sigName (SpecSig n _ _) = Just n
289 sigName (InlineSig _ n _ _) = Just n
290 sigName (FixSig (FixitySig n _ _)) = Just n
291 sigName other = Nothing
293 isFixitySig :: Sig name -> Bool
294 isFixitySig (FixSig _) = True
295 isFixitySig _ = False
297 isClassOpSig :: Sig name -> Bool
298 isClassOpSig (ClassOpSig _ _ _ _) = True
299 isClassOpSig _ = False
301 isPragSig :: Sig name -> Bool
302 -- Identifies pragmas
303 isPragSig (SpecSig _ _ _) = True
304 isPragSig (InlineSig _ _ _ _) = True
305 isPragSig (SpecInstSig _ _) = True
306 isPragSig other = False
310 hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc)
311 hsSigDoc (ClassOpSig _ _ _ loc) = (ptext SLIT("class-method type signature"), loc)
312 hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc)
313 hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc)
314 hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc)
315 hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),loc)
316 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
320 instance (Outputable name) => Outputable (Sig name) where
321 ppr sig = ppr_sig sig
323 ppr_sig :: Outputable name => Sig name -> SDoc
324 ppr_sig (Sig var ty _)
325 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
327 ppr_sig (ClassOpSig var dm ty _)
328 = sep [ pprHsVar var <+> dcolon,
330 nest 4 (pp_dm_comment) ]
333 DefMeth _ -> equals -- Default method indicator
334 GenDefMeth -> semi -- Generic method indicator
335 NoDefMeth -> empty -- No Method at all
336 pp_dm_comment = case dm of
337 DefMeth _ -> text "{- has default method -}"
338 GenDefMeth -> text "{- has generic method -}"
339 NoDefMeth -> empty -- No Method at all
341 ppr_sig (SpecSig var ty _)
342 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
343 nest 4 (ppr ty <+> text "#-}")
346 ppr_sig (InlineSig True var phase _)
347 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
349 ppr_sig (InlineSig False var phase _)
350 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
352 ppr_sig (SpecInstSig ty _)
353 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
355 ppr_sig (FixSig fix_sig) = ppr fix_sig
358 Checking for distinct signatures; oh, so boring
362 eqHsSig :: Sig Name -> Sig Name -> Bool
363 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
364 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
366 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
367 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) =
368 -- may have many specialisations for one value;
369 -- but not ones that are exactly the same...
370 (n1 == n2) && (ty1 == ty2)
372 eqHsSig _other1 _other2 = False