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 PprCore ( {- instance Outputable (Expr a) -} )
25 import PrelNames ( isUnboundName )
26 import NameSet ( NameSet, elemNameSet, nameSetToList )
27 import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..), IPName )
29 import SrcLoc ( SrcLoc )
31 import Class ( DefMeth (..) )
34 %************************************************************************
36 \subsection{Bindings: @HsBinds@}
38 %************************************************************************
40 The following syntax may produce new syntax which is not part of the input,
41 and which is instead a translation of the input to the typechecker.
42 Syntax translations are marked TRANSLATION in comments. New empty
43 productions are useful in development but may not appear in the final
46 Collections of bindings, created by dependency analysis and translation:
49 data HsBinds id -- binders and bindees
51 | ThenBinds (HsBinds id) (HsBinds id)
53 | MonoBind -- A mutually recursive group
55 [Sig id] -- Empty on typechecker output, Type Signatures
58 | IPBinds -- Implcit parameters
59 -- Not allowed at top level
60 [(IPName id, HsExpr id)]
61 Bool -- True <=> this was a 'with' binding
62 -- (tmp, until 'with' is removed)
66 nullBinds :: HsBinds id -> Bool
68 nullBinds EmptyBinds = True
69 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
70 nullBinds (MonoBind b _ _) = nullMonoBinds b
71 nullBinds (IPBinds b _) = null b
73 mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
74 mkMonoBind _ EmptyMonoBinds = EmptyBinds
75 mkMonoBind is_rec mbinds = MonoBind mbinds [] is_rec
79 instance (OutputableBndr id) => Outputable (HsBinds id) where
80 ppr binds = ppr_binds binds
82 ppr_binds EmptyBinds = empty
83 ppr_binds (ThenBinds binds1 binds2)
84 = ppr_binds binds1 $$ ppr_binds binds2
86 ppr_binds (IPBinds binds is_with)
87 = sep (punctuate semi (map pp_item binds))
89 pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs
91 ppr_binds (MonoBind bind sigs is_rec)
97 ppr_isrec = getPprStyle $ \ sty ->
98 if userStyle sty then empty else
100 Recursive -> ptext SLIT("{- rec -}")
101 NonRecursive -> ptext SLIT("{- nonrec -}")
104 %************************************************************************
106 \subsection{Bindings: @MonoBinds@}
108 %************************************************************************
110 Global bindings (where clauses)
116 | AndMonoBinds (MonoBinds id)
119 | FunMonoBind id -- Used for both functions f x = e
120 -- and variables f = \x -> e
121 -- Reason: the Match stuff lets us have an optional
122 -- result type sig f :: a->a = ...mentions a...
124 -- This also means that instance decls can only have
125 -- FunMonoBinds, so if you change this, you'll need to
126 -- change e.g. rnMethodBinds
127 Bool -- True => infix declaration
131 | PatMonoBind (Pat id) -- The pattern is never a simple variable;
132 -- That case is done by FunMonoBind
136 | VarMonoBind id -- TRANSLATION
139 | AbsBinds -- Binds abstraction; TRANSLATION
140 [TyVar] -- Type variables
142 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
143 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
144 (MonoBinds id) -- The "business end"
146 -- Creates bindings for *new* (polymorphic, overloaded) locals
147 -- in terms of *old* (monomorphic, non-overloaded) ones.
149 -- See section 9 of static semantics paper for more details.
150 -- (You can get a PhD for explaining the True Meaning
151 -- of this last construct.)
163 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
166 gp = ...same again, with gm instead of fm
168 This is a pretty bad translation, because it duplicates all the bindings.
169 So the desugarer tries to do a better job:
171 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
175 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
179 -- We keep the invariant that a MonoBinds is only empty
180 -- if it is exactly EmptyMonoBinds
182 nullMonoBinds :: MonoBinds id -> Bool
183 nullMonoBinds EmptyMonoBinds = True
184 nullMonoBinds other_monobind = False
186 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
187 andMonoBinds EmptyMonoBinds mb = mb
188 andMonoBinds mb EmptyMonoBinds = mb
189 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
191 andMonoBindList :: [MonoBinds id] -> MonoBinds id
192 andMonoBindList binds
195 loop1 [] = EmptyMonoBinds
196 loop1 (EmptyMonoBinds : binds) = loop1 binds
197 loop1 (b:bs) = loop2 b bs
201 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
202 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
207 instance OutputableBndr id => Outputable (MonoBinds id) where
208 ppr mbind = ppr_monobind mbind
211 ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
212 ppr_monobind EmptyMonoBinds = empty
213 ppr_monobind (AndMonoBinds binds1 binds2)
214 = ppr_monobind binds1 $$ ppr_monobind binds2
216 ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
217 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
218 -- ToDo: print infix if appropriate
220 ppr_monobind (VarMonoBind name expr)
221 = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
223 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
224 = sep [ptext SLIT("AbsBinds"),
225 brackets (interpp'SP tyvars),
226 brackets (interpp'SP dictvars),
227 brackets (sep (punctuate comma (map ppr exports))),
228 brackets (interpp'SP (nameSetToList inlines))]
230 nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
231 -- Print type signatures
236 %************************************************************************
238 \subsection{@Sig@: type signatures and value-modifying user pragmas}
240 %************************************************************************
242 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
243 ``specialise this function to these four types...'') in with type
244 signatures. Then all the machinery to move them into place, etc.,
249 = Sig name -- a bog-std type signature
253 | ClassOpSig name -- Selector name
254 (DefMeth name) -- Default-method info
255 -- See "THE NAMING STORY" in HsDecls
259 | SpecSig name -- specialise a function or datatype ...
260 (HsType name) -- ... to these types
263 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
264 name -- Function name
265 Activation -- When inlining is *active*
268 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
269 -- current instance decl
272 | FixSig (FixitySig name) -- Fixity declaration
276 okBindSig :: NameSet -> Sig Name -> Bool
277 okBindSig ns (ClassOpSig _ _ _ _) = False
278 okBindSig ns sig = sigForThisGroup ns sig
280 okClsDclSig :: Sig Name -> Bool
281 okClsDclSig (Sig _ _ _) = False
282 okClsDclSig (SpecInstSig _ _) = False
283 okClsDclSig sig = True -- All others OK
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