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 :: NameSet -> Sig Name -> Bool
281 okClsDclSig ns (Sig _ _ _) = False
282 okClsDclSig ns sig = sigForThisGroup ns sig
284 okInstDclSig :: NameSet -> Sig Name -> Bool
285 okInstDclSig ns (Sig _ _ _) = False
286 okInstDclSig ns (FixSig _) = False
287 okInstDclSig ns (SpecInstSig _ _) = True
288 okInstDclSig ns sig = sigForThisGroup ns sig
290 sigForThisGroup ns sig
291 = case sigName sig of
293 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
294 | otherwise -> n `elemNameSet` ns
296 sigName :: Sig name -> Maybe name
297 sigName (Sig n _ _) = Just n
298 sigName (ClassOpSig n _ _ _) = Just n
299 sigName (SpecSig n _ _) = Just n
300 sigName (InlineSig _ n _ _) = Just n
301 sigName (FixSig (FixitySig n _ _)) = Just n
302 sigName other = Nothing
304 isFixitySig :: Sig name -> Bool
305 isFixitySig (FixSig _) = True
306 isFixitySig _ = False
308 isClassOpSig :: Sig name -> Bool
309 isClassOpSig (ClassOpSig _ _ _ _) = True
310 isClassOpSig _ = False
312 isPragSig :: Sig name -> Bool
313 -- Identifies pragmas
314 isPragSig (SpecSig _ _ _) = True
315 isPragSig (InlineSig _ _ _ _) = True
316 isPragSig (SpecInstSig _ _) = True
317 isPragSig other = False
321 hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc)
322 hsSigDoc (ClassOpSig _ _ _ loc) = (ptext SLIT("class-method type signature"), loc)
323 hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc)
324 hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc)
325 hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc)
326 hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),loc)
327 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
331 instance (Outputable name) => Outputable (Sig name) where
332 ppr sig = ppr_sig sig
334 ppr_sig :: Outputable name => Sig name -> SDoc
335 ppr_sig (Sig var ty _)
336 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
338 ppr_sig (ClassOpSig var dm ty _)
339 = sep [ pprHsVar var <+> dcolon,
341 nest 4 (pp_dm_comment) ]
344 DefMeth _ -> equals -- Default method indicator
345 GenDefMeth -> semi -- Generic method indicator
346 NoDefMeth -> empty -- No Method at all
347 pp_dm_comment = case dm of
348 DefMeth _ -> text "{- has default method -}"
349 GenDefMeth -> text "{- has generic method -}"
350 NoDefMeth -> empty -- No Method at all
352 ppr_sig (SpecSig var ty _)
353 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
354 nest 4 (ppr ty <+> text "#-}")
357 ppr_sig (InlineSig True var phase _)
358 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
360 ppr_sig (InlineSig False var phase _)
361 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
363 ppr_sig (SpecInstSig ty _)
364 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
366 ppr_sig (FixSig fix_sig) = ppr fix_sig
369 Checking for distinct signatures; oh, so boring
373 eqHsSig :: Sig Name -> Sig Name -> Bool
374 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
375 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
377 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
378 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) =
379 -- may have many specialisations for one value;
380 -- but not ones that are exactly the same...
381 (n1 == n2) && (ty1 == ty2)
383 eqHsSig _other1 _other2 = False