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 ( pprExpr, HsExpr )
14 import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
17 import HsTypes ( HsType )
18 import HsImpExp ( IE(..), ieName )
19 import CoreSyn ( CoreExpr )
20 import PprCore () -- Instances for Outputable
24 import Name ( Name, isUnboundName )
25 import NameSet ( NameSet, elemNameSet, nameSetToList )
26 import BasicTypes ( RecFlag(..), Fixity )
29 import SrcLoc ( SrcLoc )
31 import Util ( thenCmp )
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)
81 = vcat [ifNotPprForUser (ptext rec_str),
86 rec_str = case is_rec of
87 Recursive -> SLIT("{- rec -}")
88 NonRecursive -> SLIT("{- nonrec -}")
91 %************************************************************************
93 \subsection{Bindings: @MonoBinds@}
95 %************************************************************************
97 Global bindings (where clauses)
100 data MonoBinds id pat
103 | AndMonoBinds (MonoBinds id pat)
106 | FunMonoBind id -- Used for both functions f x = e
107 -- and variables f = \x -> e
108 -- Reason: the Match stuff lets us have an optional
109 -- result type sig f :: a->a = ...mentions a...
110 Bool -- True => infix declaration
114 | PatMonoBind pat -- The pattern is never a simple variable;
115 -- That case is done by FunMonoBind
119 | VarMonoBind id -- TRANSLATION
122 | CoreMonoBind id -- TRANSLATION
123 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
125 | AbsBinds -- Binds abstraction; TRANSLATION
126 [TyVar] -- Type variables
128 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
129 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
130 (MonoBinds id pat) -- The "business end"
132 -- Creates bindings for *new* (polymorphic, overloaded) locals
133 -- in terms of *old* (monomorphic, non-overloaded) ones.
135 -- See section 9 of static semantics paper for more details.
136 -- (You can get a PhD for explaining the True Meaning
137 -- of this last construct.)
149 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
152 gp = ...same again, with gm instead of fm
154 This is a pretty bad translation, because it duplicates all the bindings.
155 So the desugarer tries to do a better job:
157 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
161 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
165 -- We keep the invariant that a MonoBinds is only empty
166 -- if it is exactly EmptyMonoBinds
168 nullMonoBinds :: MonoBinds id pat -> Bool
169 nullMonoBinds EmptyMonoBinds = True
170 nullMonoBinds other_monobind = False
172 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
173 andMonoBinds EmptyMonoBinds mb = mb
174 andMonoBinds mb EmptyMonoBinds = mb
175 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
177 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
178 andMonoBindList binds
181 loop1 [] = EmptyMonoBinds
182 loop1 (EmptyMonoBinds : binds) = loop1 binds
183 loop1 (b:bs) = loop2 b bs
187 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
188 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
193 instance (Outputable id, Outputable pat) =>
194 Outputable (MonoBinds id pat) where
195 ppr mbind = ppr_monobind mbind
198 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
199 ppr_monobind EmptyMonoBinds = empty
200 ppr_monobind (AndMonoBinds binds1 binds2)
201 = ppr_monobind binds1 $$ ppr_monobind binds2
203 ppr_monobind (PatMonoBind pat grhss locn)
204 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
206 ppr_monobind (FunMonoBind fun inf matches locn)
207 = pprMatches (False, ppr fun) matches
208 -- ToDo: print infix if appropriate
210 ppr_monobind (VarMonoBind name expr)
211 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
213 ppr_monobind (CoreMonoBind name expr)
214 = sep [ppr name <+> equals, nest 4 (ppr expr)]
216 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
217 = sep [ptext SLIT("AbsBinds"),
218 brackets (interpp'SP tyvars),
219 brackets (interpp'SP dictvars),
220 brackets (sep (punctuate comma (map ppr exports))),
221 brackets (interpp'SP (nameSetToList inlines))]
223 nest 4 (ppr val_binds)
226 %************************************************************************
228 \subsection{@Sig@: type signatures and value-modifying user pragmas}
230 %************************************************************************
232 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
233 ``specialise this function to these four types...'') in with type
234 signatures. Then all the machinery to move them into place, etc.,
239 = Sig name -- a bog-std type signature
243 | ClassOpSig name -- Selector name
244 name -- Default-method name (if any)
245 Bool -- True <=> there is an explicit, programmer-supplied
246 -- default declaration in the class decl
250 | SpecSig name -- specialise a function or datatype ...
251 (HsType name) -- ... to these types
254 | InlineSig name -- INLINE f
258 | NoInlineSig name -- NOINLINE f
262 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
263 -- current instance decl
266 | FixSig (FixitySig name) -- Fixity declaration
269 data FixitySig name = FixitySig name Fixity SrcLoc
271 instance Eq name => Eq (FixitySig name) where
272 (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
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 (NoInlineSig 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 (NoInlineSig _ _ _) = True
318 isPragSig (SpecInstSig _ _) = True
319 isPragSig other = False
323 hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
324 hsSigDoc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc)
325 hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
326 hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
327 hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
328 hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
329 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
333 instance (Outputable name) => Outputable (Sig name) where
334 ppr sig = ppr_sig sig
336 ppr_sig :: Outputable name => Sig name -> SDoc
337 ppr_sig (Sig var ty _)
338 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
340 ppr_sig (ClassOpSig var _ dm ty _)
341 = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
343 pp_dm = if dm then equals else empty -- Default-method indicator
345 ppr_sig (SpecSig var ty _)
346 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
347 nest 4 (ppr ty <+> text "#-}")
350 ppr_sig (InlineSig var phase _)
351 = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
353 ppr_sig (NoInlineSig var phase _)
354 = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
356 ppr_sig (SpecInstSig ty _)
357 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
359 ppr_sig (FixSig fix_sig) = ppr fix_sig
362 instance Outputable name => Outputable (FixitySig name) where
363 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
365 ppr_phase :: Maybe Int -> SDoc
366 ppr_phase Nothing = empty
367 ppr_phase (Just n) = int n
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 n1 _ _) (InlineSig n2 _ _) = n1 == n2
377 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
379 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
380 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
381 = -- may have many specialisations for one value;
382 -- but not ones that are exactly the same...
383 (n1 == n2) && (ty1 == ty2)
385 eqHsSig other_1 other_2 = False