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(..), IPName )
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
52 | ThenBinds (HsBinds id) (HsBinds id)
54 | MonoBind -- A mutually recursive group
56 [Sig id] -- Empty on typechecker output, Type Signatures
59 | IPBinds -- Implcit parameters
60 -- Not allowed at top level
61 [(IPName id, HsExpr id)]
62 Bool -- True <=> this was a 'with' binding
63 -- (tmp, until 'with' is removed)
67 nullBinds :: HsBinds id -> Bool
69 nullBinds EmptyBinds = True
70 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
71 nullBinds (MonoBind b _ _) = nullMonoBinds b
72 nullBinds (IPBinds b _) = null b
74 mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
75 mkMonoBind _ EmptyMonoBinds = EmptyBinds
76 mkMonoBind is_rec mbinds = MonoBind mbinds [] is_rec
80 instance (OutputableBndr id) => Outputable (HsBinds id) where
81 ppr binds = ppr_binds binds
83 ppr_binds EmptyBinds = empty
84 ppr_binds (ThenBinds binds1 binds2)
85 = ppr_binds binds1 $$ ppr_binds binds2
87 ppr_binds (IPBinds binds is_with)
88 = sep (punctuate semi (map pp_item binds))
90 pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs
92 ppr_binds (MonoBind bind sigs is_rec)
98 ppr_isrec = getPprStyle $ \ sty ->
99 if userStyle sty then empty else
101 Recursive -> ptext SLIT("{- rec -}")
102 NonRecursive -> ptext SLIT("{- nonrec -}")
105 %************************************************************************
107 \subsection{Bindings: @MonoBinds@}
109 %************************************************************************
111 Global bindings (where clauses)
117 | AndMonoBinds (MonoBinds id)
120 | FunMonoBind id -- Used for both functions f x = e
121 -- and variables f = \x -> e
122 -- Reason: the Match stuff lets us have an optional
123 -- result type sig f :: a->a = ...mentions a...
125 -- This also means that instance decls can only have
126 -- FunMonoBinds, so if you change this, you'll need to
127 -- change e.g. rnMethodBinds
128 Bool -- True => infix declaration
132 | PatMonoBind (Pat id) -- The pattern is never a simple variable;
133 -- That case is done by FunMonoBind
137 | VarMonoBind id -- TRANSLATION
140 | AbsBinds -- Binds abstraction; TRANSLATION
141 [TyVar] -- Type variables
143 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
144 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
145 (MonoBinds id) -- The "business end"
147 -- Creates bindings for *new* (polymorphic, overloaded) locals
148 -- in terms of *old* (monomorphic, non-overloaded) ones.
150 -- See section 9 of static semantics paper for more details.
151 -- (You can get a PhD for explaining the True Meaning
152 -- of this last construct.)
164 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
167 gp = ...same again, with gm instead of fm
169 This is a pretty bad translation, because it duplicates all the bindings.
170 So the desugarer tries to do a better job:
172 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
176 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
180 -- We keep the invariant that a MonoBinds is only empty
181 -- if it is exactly EmptyMonoBinds
183 nullMonoBinds :: MonoBinds id -> Bool
184 nullMonoBinds EmptyMonoBinds = True
185 nullMonoBinds other_monobind = False
187 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
188 andMonoBinds EmptyMonoBinds mb = mb
189 andMonoBinds mb EmptyMonoBinds = mb
190 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
192 andMonoBindList :: [MonoBinds id] -> MonoBinds id
193 andMonoBindList binds
196 loop1 [] = EmptyMonoBinds
197 loop1 (EmptyMonoBinds : binds) = loop1 binds
198 loop1 (b:bs) = loop2 b bs
202 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
203 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
208 instance OutputableBndr id => Outputable (MonoBinds id) where
209 ppr mbind = ppr_monobind mbind
212 ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
213 ppr_monobind EmptyMonoBinds = empty
214 ppr_monobind (AndMonoBinds binds1 binds2)
215 = ppr_monobind binds1 $$ ppr_monobind binds2
217 ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
218 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
219 -- ToDo: print infix if appropriate
221 ppr_monobind (VarMonoBind name expr)
222 = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
224 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
225 = sep [ptext SLIT("AbsBinds"),
226 brackets (interpp'SP tyvars),
227 brackets (interpp'SP dictvars),
228 brackets (sep (punctuate comma (map ppr exports))),
229 brackets (interpp'SP (nameSetToList inlines))]
231 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
232 -- Print type signatures
237 %************************************************************************
239 \subsection{@Sig@: type signatures and value-modifying user pragmas}
241 %************************************************************************
243 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
244 ``specialise this function to these four types...'') in with type
245 signatures. Then all the machinery to move them into place, etc.,
250 = Sig name -- a bog-std type signature
254 | ClassOpSig name -- Selector name
255 (DefMeth name) -- Default-method info
256 -- See "THE NAMING STORY" in HsDecls
260 | SpecSig name -- specialise a function or datatype ...
261 (HsType name) -- ... to these types
264 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
265 name -- Function name
266 Activation -- When inlining is *active*
269 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
270 -- current instance decl
273 | FixSig (FixitySig name) -- Fixity declaration
277 okBindSig :: NameSet -> Sig Name -> Bool
278 okBindSig ns (ClassOpSig _ _ _ _) = False
279 okBindSig ns sig = sigForThisGroup ns sig
281 okClsDclSig :: NameSet -> Sig Name -> Bool
282 okClsDclSig ns (Sig _ _ _) = False
283 okClsDclSig ns sig = sigForThisGroup ns sig
285 okInstDclSig :: NameSet -> Sig Name -> Bool
286 okInstDclSig ns (Sig _ _ _) = False
287 okInstDclSig ns (FixSig _) = False
288 okInstDclSig ns (SpecInstSig _ _) = True
289 okInstDclSig ns sig = sigForThisGroup ns sig
291 sigForThisGroup ns sig
292 = case sigName sig of
294 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
295 | otherwise -> n `elemNameSet` ns
297 sigName :: Sig name -> Maybe name
298 sigName (Sig n _ _) = Just n
299 sigName (ClassOpSig n _ _ _) = Just n
300 sigName (SpecSig n _ _) = Just n
301 sigName (InlineSig _ n _ _) = Just n
302 sigName (FixSig (FixitySig n _ _)) = Just n
303 sigName other = Nothing
305 isFixitySig :: Sig name -> Bool
306 isFixitySig (FixSig _) = True
307 isFixitySig _ = False
309 isClassOpSig :: Sig name -> Bool
310 isClassOpSig (ClassOpSig _ _ _ _) = True
311 isClassOpSig _ = False
313 isPragSig :: Sig name -> Bool
314 -- Identifies pragmas
315 isPragSig (SpecSig _ _ _) = True
316 isPragSig (InlineSig _ _ _ _) = True
317 isPragSig (SpecInstSig _ _) = True
318 isPragSig other = False
322 hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc)
323 hsSigDoc (ClassOpSig _ _ _ loc) = (ptext SLIT("class-method type signature"), loc)
324 hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc)
325 hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc)
326 hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc)
327 hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),loc)
328 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
332 instance (Outputable name) => Outputable (Sig name) where
333 ppr sig = ppr_sig sig
335 ppr_sig :: Outputable name => Sig name -> SDoc
336 ppr_sig (Sig var ty _)
337 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
339 ppr_sig (ClassOpSig var dm ty _)
340 = sep [ pprHsVar var <+> dcolon,
342 nest 4 (pp_dm_comment) ]
345 DefMeth _ -> equals -- Default method indicator
346 GenDefMeth -> semi -- Generic method indicator
347 NoDefMeth -> empty -- No Method at all
348 pp_dm_comment = case dm of
349 DefMeth _ -> text "{- has default method -}"
350 GenDefMeth -> text "{- has generic method -}"
351 NoDefMeth -> empty -- No Method at all
353 ppr_sig (SpecSig var ty _)
354 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
355 nest 4 (ppr ty <+> text "#-}")
358 ppr_sig (InlineSig True var phase _)
359 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
361 ppr_sig (InlineSig False var phase _)
362 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
364 ppr_sig (SpecInstSig ty _)
365 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
367 ppr_sig (FixSig fix_sig) = ppr fix_sig
370 Checking for distinct signatures; oh, so boring
374 eqHsSig :: Sig Name -> Sig Name -> Bool
375 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
376 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
378 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
379 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) =
380 -- may have many specialisations for one value;
381 -- but not ones that are exactly the same...
382 (n1 == n2) && (ty1 == ty2)
384 eqHsSig _other1 _other2 = False