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 ( ppr_var )
19 import HsTypes ( HsType )
20 import CoreSyn ( CoreExpr )
21 import PprCore ( {- instance Outputable (Expr a) -} )
25 import PrelNames ( isUnboundName )
26 import NameSet ( NameSet, elemNameSet, nameSetToList )
27 import BasicTypes ( RecFlag(..), Fixity, Activation(..) )
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 pat -- binders and bindees
52 | ThenBinds (HsBinds id pat)
55 | MonoBind (MonoBinds id pat)
56 [Sig id] -- Empty on typechecker output
61 nullBinds :: HsBinds id pat -> Bool
63 nullBinds EmptyBinds = True
64 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
65 nullBinds (MonoBind b _ _) = nullMonoBinds b
67 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
68 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
69 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
73 instance (Outputable pat, Outputable id) =>
74 Outputable (HsBinds id pat) 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)
102 data MonoBinds id pat
105 | AndMonoBinds (MonoBinds id pat)
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 -- The pattern is never a simple variable;
121 -- That case is done by FunMonoBind
125 | VarMonoBind id -- TRANSLATION
128 | CoreMonoBind id -- TRANSLATION
129 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
131 | AbsBinds -- Binds abstraction; TRANSLATION
132 [TyVar] -- Type variables
134 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
135 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
136 (MonoBinds id pat) -- The "business end"
138 -- Creates bindings for *new* (polymorphic, overloaded) locals
139 -- in terms of *old* (monomorphic, non-overloaded) ones.
141 -- See section 9 of static semantics paper for more details.
142 -- (You can get a PhD for explaining the True Meaning
143 -- of this last construct.)
155 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
158 gp = ...same again, with gm instead of fm
160 This is a pretty bad translation, because it duplicates all the bindings.
161 So the desugarer tries to do a better job:
163 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
167 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
171 -- We keep the invariant that a MonoBinds is only empty
172 -- if it is exactly EmptyMonoBinds
174 nullMonoBinds :: MonoBinds id pat -> Bool
175 nullMonoBinds EmptyMonoBinds = True
176 nullMonoBinds other_monobind = False
178 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
179 andMonoBinds EmptyMonoBinds mb = mb
180 andMonoBinds mb EmptyMonoBinds = mb
181 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
183 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
184 andMonoBindList binds
187 loop1 [] = EmptyMonoBinds
188 loop1 (EmptyMonoBinds : binds) = loop1 binds
189 loop1 (b:bs) = loop2 b bs
193 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
194 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
199 instance (Outputable id, Outputable pat) =>
200 Outputable (MonoBinds id pat) where
201 ppr mbind = ppr_monobind mbind
204 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
205 ppr_monobind EmptyMonoBinds = empty
206 ppr_monobind (AndMonoBinds binds1 binds2)
207 = ppr_monobind binds1 $$ ppr_monobind binds2
209 ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
210 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
211 -- ToDo: print infix if appropriate
213 ppr_monobind (VarMonoBind name expr)
214 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
216 ppr_monobind (CoreMonoBind name expr)
217 = sep [ppr name <+> equals, nest 4 (ppr expr)]
219 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
220 = sep [ptext SLIT("AbsBinds"),
221 brackets (interpp'SP tyvars),
222 brackets (interpp'SP dictvars),
223 brackets (sep (punctuate comma (map ppr exports))),
224 brackets (interpp'SP (nameSetToList inlines))]
226 nest 4 (ppr val_binds)
229 %************************************************************************
231 \subsection{@Sig@: type signatures and value-modifying user pragmas}
233 %************************************************************************
235 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
236 ``specialise this function to these four types...'') in with type
237 signatures. Then all the machinery to move them into place, etc.,
242 = Sig name -- a bog-std type signature
246 | ClassOpSig name -- Selector name
247 (DefMeth name) -- Default-method info
248 -- See "THE NAMING STORY" in HsDecls
252 | SpecSig name -- specialise a function or datatype ...
253 (HsType name) -- ... to these types
256 | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
257 name -- Function name
258 Activation -- When inlining is *active*
261 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
262 -- current instance decl
265 | FixSig (FixitySig name) -- Fixity declaration
268 data FixitySig name = FixitySig name Fixity SrcLoc
270 instance Eq name => Eq (FixitySig name) where
271 (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
275 okBindSig :: NameSet -> Sig Name -> Bool
276 okBindSig ns (ClassOpSig _ _ _ _) = False
277 okBindSig ns sig = sigForThisGroup ns sig
279 okClsDclSig :: NameSet -> Sig Name -> Bool
280 okClsDclSig ns (Sig _ _ _) = False
281 okClsDclSig ns sig = sigForThisGroup ns sig
283 okInstDclSig :: NameSet -> Sig Name -> Bool
284 okInstDclSig ns (Sig _ _ _) = False
285 okInstDclSig ns (FixSig _) = False
286 okInstDclSig ns (SpecInstSig _ _) = True
287 okInstDclSig ns sig = sigForThisGroup ns sig
289 sigForThisGroup ns sig
290 = case sigName sig of
292 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
293 | otherwise -> n `elemNameSet` ns
295 sigName :: Sig name -> Maybe name
296 sigName (Sig n _ _) = Just n
297 sigName (ClassOpSig n _ _ _) = Just n
298 sigName (SpecSig n _ _) = Just n
299 sigName (InlineSig _ n _ _) = Just n
300 sigName (FixSig (FixitySig n _ _)) = Just n
301 sigName other = Nothing
303 isFixitySig :: Sig name -> Bool
304 isFixitySig (FixSig _) = True
305 isFixitySig _ = False
307 isClassOpSig :: Sig name -> Bool
308 isClassOpSig (ClassOpSig _ _ _ _) = True
309 isClassOpSig _ = False
311 isPragSig :: Sig name -> Bool
312 -- Identifies pragmas
313 isPragSig (SpecSig _ _ _) = True
314 isPragSig (InlineSig _ _ _ _) = True
315 isPragSig (SpecInstSig _ _) = True
316 isPragSig other = False
320 hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
321 hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
322 hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
323 hsSigDoc (InlineSig True _ _ loc) = (SLIT("INLINE pragma"),loc)
324 hsSigDoc (InlineSig False _ _ loc) = (SLIT("NOINLINE pragma"),loc)
325 hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
326 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
330 instance (Outputable name) => Outputable (Sig name) where
331 ppr sig = ppr_sig sig
333 ppr_sig :: Outputable name => Sig name -> SDoc
334 ppr_sig (Sig var ty _)
335 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
337 ppr_sig (ClassOpSig var dm ty _)
338 = sep [ ppr_var var <+> dcolon,
340 nest 4 (pp_dm_comment) ]
343 DefMeth _ -> equals -- Default method indicator
344 GenDefMeth -> semi -- Generic method indicator
345 NoDefMeth -> empty -- No Method at all
346 pp_dm_comment = case dm of
347 DefMeth _ -> text "{- has default method -}"
348 GenDefMeth -> text "{- has generic method -}"
349 NoDefMeth -> empty -- No Method at all
351 ppr_sig (SpecSig var ty _)
352 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
353 nest 4 (ppr ty <+> text "#-}")
356 ppr_sig (InlineSig True var phase _)
357 = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
359 ppr_sig (InlineSig False var phase _)
360 = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
362 ppr_sig (SpecInstSig ty _)
363 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
365 ppr_sig (FixSig fix_sig) = ppr fix_sig
368 instance Outputable name => Outputable (FixitySig name) where
369 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
372 Checking for distinct signatures; oh, so boring
376 eqHsSig :: Sig Name -> Sig Name -> Bool
377 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
378 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
380 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
381 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) =
382 -- may have many specialisations for one value;
383 -- but not ones that are exactly the same...
384 (n1 == n2) && (ty1 == ty2)
386 eqHsSig _other1 _other2 = False