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 CoreSyn ( CoreExpr )
21 import Name ( Name, isUnboundName )
22 import NameSet ( NameSet, elemNameSet, nameSetToList )
23 import BasicTypes ( RecFlag(..), Fixity )
25 import SrcLoc ( SrcLoc )
29 %************************************************************************
31 \subsection{Bindings: @HsBinds@}
33 %************************************************************************
35 The following syntax may produce new syntax which is not part of the input,
36 and which is instead a translation of the input to the typechecker.
37 Syntax translations are marked TRANSLATION in comments. New empty
38 productions are useful in development but may not appear in the final
41 Collections of bindings, created by dependency analysis and translation:
44 data HsBinds id pat -- binders and bindees
47 | ThenBinds (HsBinds id pat)
50 | MonoBind (MonoBinds id pat)
51 [Sig id] -- Empty on typechecker output
56 nullBinds :: HsBinds id pat -> Bool
58 nullBinds EmptyBinds = True
59 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
60 nullBinds (MonoBind b _ _) = nullMonoBinds b
62 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
63 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
64 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
68 instance (Outputable pat, Outputable id) =>
69 Outputable (HsBinds id pat) where
70 ppr binds = ppr_binds binds
72 ppr_binds EmptyBinds = empty
73 ppr_binds (ThenBinds binds1 binds2)
74 = ($$) (ppr_binds binds1) (ppr_binds binds2)
75 ppr_binds (MonoBind bind sigs is_rec)
76 = vcat [ifNotPprForUser (ptext rec_str),
81 rec_str = case is_rec of
82 Recursive -> SLIT("{- rec -}")
83 NonRecursive -> SLIT("{- nonrec -}")
86 %************************************************************************
88 \subsection{Bindings: @MonoBinds@}
90 %************************************************************************
92 Global bindings (where clauses)
98 | AndMonoBinds (MonoBinds id pat)
101 | FunMonoBind id -- Used for both functions f x = e
102 -- and variables f = \x -> e
103 -- Reason: the Match stuff lets us have an optional
104 -- result type sig f :: a->a = ...mentions a...
105 Bool -- True => infix declaration
109 | PatMonoBind pat -- The pattern is never a simple variable;
110 -- That case is done by FunMonoBind
114 | VarMonoBind id -- TRANSLATION
117 | CoreMonoBind id -- TRANSLATION
118 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
120 | AbsBinds -- Binds abstraction; TRANSLATION
121 [TyVar] -- Type variables
123 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
124 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
125 (MonoBinds id pat) -- The "business end"
127 -- Creates bindings for *new* (polymorphic, overloaded) locals
128 -- in terms of *old* (monomorphic, non-overloaded) ones.
130 -- See section 9 of static semantics paper for more details.
131 -- (You can get a PhD for explaining the True Meaning
132 -- of this last construct.)
144 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
147 gp = ...same again, with gm instead of fm
149 This is a pretty bad translation, because it duplicates all the bindings.
150 So the desugarer tries to do a better job:
152 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
156 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
160 -- We keep the invariant that a MonoBinds is only empty
161 -- if it is exactly EmptyMonoBinds
163 nullMonoBinds :: MonoBinds id pat -> Bool
164 nullMonoBinds EmptyMonoBinds = True
165 nullMonoBinds other_monobind = False
167 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
168 andMonoBinds EmptyMonoBinds mb = mb
169 andMonoBinds mb EmptyMonoBinds = mb
170 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
172 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
173 andMonoBindList binds
176 loop1 [] = EmptyMonoBinds
177 loop1 (EmptyMonoBinds : binds) = loop1 binds
178 loop1 (b:bs) = loop2 b bs
182 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
183 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
188 instance (Outputable id, Outputable pat) =>
189 Outputable (MonoBinds id pat) where
190 ppr mbind = ppr_monobind mbind
193 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
194 ppr_monobind EmptyMonoBinds = empty
195 ppr_monobind (AndMonoBinds binds1 binds2)
196 = ppr_monobind binds1 $$ ppr_monobind binds2
198 ppr_monobind (PatMonoBind pat grhss locn)
199 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
201 ppr_monobind (FunMonoBind fun inf matches locn)
202 = pprMatches (False, ppr fun) matches
203 -- ToDo: print infix if appropriate
205 ppr_monobind (VarMonoBind name expr)
206 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
208 ppr_monobind (CoreMonoBind name expr)
209 = sep [ppr name <+> equals, nest 4 (ppr expr)]
211 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
212 = sep [ptext SLIT("AbsBinds"),
213 brackets (interpp'SP tyvars),
214 brackets (interpp'SP dictvars),
215 brackets (sep (punctuate comma (map ppr exports))),
216 brackets (interpp'SP (nameSetToList inlines))]
218 nest 4 (ppr val_binds)
221 %************************************************************************
223 \subsection{@Sig@: type signatures and value-modifying user pragmas}
225 %************************************************************************
227 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
228 ``specialise this function to these four types...'') in with type
229 signatures. Then all the machinery to move them into place, etc.,
234 = Sig name -- a bog-std type signature
238 | ClassOpSig name -- Selector name
239 (Maybe -- Nothing for source-file class signatures
240 (name, -- Default-method name (if any)
241 Bool)) -- True <=> there is an explicit, programmer-supplied
242 -- default declaration in the class decl
246 | SpecSig name -- specialise a function or datatype ...
247 (HsType name) -- ... to these types
250 | InlineSig name -- INLINE f
254 | NoInlineSig name -- NOINLINE f
258 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
259 -- current instance decl
262 | FixSig (FixitySig name) -- Fixity declaration
265 data FixitySig name = FixitySig name Fixity SrcLoc
267 instance Eq name => Eq (FixitySig name) where
268 (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
272 okBindSig :: NameSet -> Sig Name -> Bool
273 okBindSig ns (ClassOpSig _ _ _ _) = False
274 okBindSig ns sig = sigForThisGroup ns sig
276 okClsDclSig :: NameSet -> Sig Name -> Bool
277 okClsDclSig ns (Sig _ _ _) = False
278 okClsDclSig ns sig = sigForThisGroup ns sig
280 okInstDclSig :: NameSet -> Sig Name -> Bool
281 okInstDclSig ns (Sig _ _ _) = False
282 okInstDclSig ns (FixSig _) = False
283 okInstDclSig ns (SpecInstSig _ _) = True
284 okInstDclSig ns sig = sigForThisGroup ns sig
286 sigForThisGroup ns sig
287 = case sigName sig of
289 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
290 | otherwise -> n `elemNameSet` ns
292 sigName :: Sig name -> Maybe name
293 sigName (Sig n _ _) = Just n
294 sigName (ClassOpSig n _ _ _) = Just n
295 sigName (SpecSig n _ _) = Just n
296 sigName (InlineSig n _ _) = Just n
297 sigName (NoInlineSig n _ _) = Just n
298 sigName (FixSig (FixitySig n _ _)) = Just n
299 sigName other = Nothing
301 isFixitySig :: Sig name -> Bool
302 isFixitySig (FixSig _) = True
303 isFixitySig _ = False
305 isClassOpSig :: Sig name -> Bool
306 isClassOpSig (ClassOpSig _ _ _ _) = True
307 isClassOpSig _ = False
309 isPragSig :: Sig name -> Bool
310 -- Identifies pragmas
311 isPragSig (SpecSig _ _ _) = True
312 isPragSig (InlineSig _ _ _) = True
313 isPragSig (NoInlineSig _ _ _) = True
314 isPragSig (SpecInstSig _ _) = True
315 isPragSig other = False
319 hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
320 hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
321 hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
322 hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
323 hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
324 hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
325 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
329 instance (Outputable name) => Outputable (Sig name) where
330 ppr sig = ppr_sig sig
332 ppr_sig :: Outputable name => Sig name -> SDoc
333 ppr_sig (Sig var ty _)
334 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
336 ppr_sig (ClassOpSig var dm ty _)
337 = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
340 Just (_, True) -> equals -- Default-method indicator
343 ppr_sig (SpecSig var ty _)
344 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
345 nest 4 (ppr ty <+> text "#-}")
348 ppr_sig (InlineSig var phase _)
349 = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
351 ppr_sig (NoInlineSig var phase _)
352 = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
354 ppr_sig (SpecInstSig ty _)
355 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
357 ppr_sig (FixSig fix_sig) = ppr fix_sig
360 instance Outputable name => Outputable (FixitySig name) where
361 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
363 ppr_phase :: Maybe Int -> SDoc
364 ppr_phase Nothing = empty
365 ppr_phase (Just n) = int n
368 Checking for distinct signatures; oh, so boring
372 eqHsSig :: Sig Name -> Sig Name -> Bool
373 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
374 eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2
375 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = 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 other_1 other_2 = False