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 )
19 import PprCore ( {- Instances -} )
22 import Name ( Name, isUnboundName )
23 import NameSet ( NameSet, elemNameSet, nameSetToList )
24 import BasicTypes ( RecFlag(..), Fixity )
26 import SrcLoc ( SrcLoc )
28 import Class ( DefMeth (..) )
31 %************************************************************************
33 \subsection{Bindings: @HsBinds@}
35 %************************************************************************
37 The following syntax may produce new syntax which is not part of the input,
38 and which is instead a translation of the input to the typechecker.
39 Syntax translations are marked TRANSLATION in comments. New empty
40 productions are useful in development but may not appear in the final
43 Collections of bindings, created by dependency analysis and translation:
46 data HsBinds id pat -- binders and bindees
49 | ThenBinds (HsBinds id pat)
52 | MonoBind (MonoBinds id pat)
53 [Sig id] -- Empty on typechecker output
58 nullBinds :: HsBinds id pat -> Bool
60 nullBinds EmptyBinds = True
61 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
62 nullBinds (MonoBind b _ _) = nullMonoBinds b
64 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
65 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
66 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
70 instance (Outputable pat, Outputable id) =>
71 Outputable (HsBinds id pat) where
72 ppr binds = ppr_binds binds
74 ppr_binds EmptyBinds = empty
75 ppr_binds (ThenBinds binds1 binds2)
76 = ($$) (ppr_binds binds1) (ppr_binds binds2)
77 ppr_binds (MonoBind bind sigs is_rec)
78 = vcat [ifNotPprForUser (ptext rec_str),
83 rec_str = case is_rec of
84 Recursive -> SLIT("{- rec -}")
85 NonRecursive -> SLIT("{- nonrec -}")
88 %************************************************************************
90 \subsection{Bindings: @MonoBinds@}
92 %************************************************************************
94 Global bindings (where clauses)
100 | AndMonoBinds (MonoBinds id pat)
103 | FunMonoBind id -- Used for both functions f x = e
104 -- and variables f = \x -> e
105 -- Reason: the Match stuff lets us have an optional
106 -- result type sig f :: a->a = ...mentions a...
107 Bool -- True => infix declaration
111 | PatMonoBind pat -- The pattern is never a simple variable;
112 -- That case is done by FunMonoBind
116 | VarMonoBind id -- TRANSLATION
119 | CoreMonoBind id -- TRANSLATION
120 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
122 | AbsBinds -- Binds abstraction; TRANSLATION
123 [TyVar] -- Type variables
125 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
126 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
127 (MonoBinds id pat) -- The "business end"
129 -- Creates bindings for *new* (polymorphic, overloaded) locals
130 -- in terms of *old* (monomorphic, non-overloaded) ones.
132 -- See section 9 of static semantics paper for more details.
133 -- (You can get a PhD for explaining the True Meaning
134 -- of this last construct.)
146 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
149 gp = ...same again, with gm instead of fm
151 This is a pretty bad translation, because it duplicates all the bindings.
152 So the desugarer tries to do a better job:
154 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
158 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
162 -- We keep the invariant that a MonoBinds is only empty
163 -- if it is exactly EmptyMonoBinds
165 nullMonoBinds :: MonoBinds id pat -> Bool
166 nullMonoBinds EmptyMonoBinds = True
167 nullMonoBinds other_monobind = False
169 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
170 andMonoBinds EmptyMonoBinds mb = mb
171 andMonoBinds mb EmptyMonoBinds = mb
172 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
174 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
175 andMonoBindList binds
178 loop1 [] = EmptyMonoBinds
179 loop1 (EmptyMonoBinds : binds) = loop1 binds
180 loop1 (b:bs) = loop2 b bs
184 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
185 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
190 instance (Outputable id, Outputable pat) =>
191 Outputable (MonoBinds id pat) where
192 ppr mbind = ppr_monobind mbind
195 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
196 ppr_monobind EmptyMonoBinds = empty
197 ppr_monobind (AndMonoBinds binds1 binds2)
198 = ppr_monobind binds1 $$ ppr_monobind binds2
200 ppr_monobind (PatMonoBind pat grhss locn)
201 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
203 ppr_monobind (FunMonoBind fun inf matches locn)
204 = pprMatches (False, ppr fun) matches
205 -- ToDo: print infix if appropriate
207 ppr_monobind (VarMonoBind name expr)
208 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
210 ppr_monobind (CoreMonoBind name expr)
211 = sep [ppr name <+> equals, nest 4 (ppr expr)]
213 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
214 = sep [ptext SLIT("AbsBinds"),
215 brackets (interpp'SP tyvars),
216 brackets (interpp'SP dictvars),
217 brackets (sep (punctuate comma (map ppr exports))),
218 brackets (interpp'SP (nameSetToList inlines))]
220 nest 4 (ppr val_binds)
223 %************************************************************************
225 \subsection{@Sig@: type signatures and value-modifying user pragmas}
227 %************************************************************************
229 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
230 ``specialise this function to these four types...'') in with type
231 signatures. Then all the machinery to move them into place, etc.,
236 = Sig name -- a bog-std type signature
240 | ClassOpSig name -- Selector name
241 (Maybe (DefMeth name)) -- Nothing for source-file class signatures
242 -- Gives DefMeth info for interface files sigs
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 (DefMeth _) -> equals -- Default method indicator
341 Just GenDefMeth -> semi -- Generic method indicator
342 Just NoDefMeth -> empty -- No Method at all
343 -- Not convinced this is right...
344 -- Not used in interface file output hopefully
345 -- but needed for ddump-rn ??
347 -- empty -- No method at all
350 ppr_sig (SpecSig var ty _)
351 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
352 nest 4 (ppr ty <+> text "#-}")
355 ppr_sig (InlineSig var phase _)
356 = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
358 ppr_sig (NoInlineSig var phase _)
359 = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
361 ppr_sig (SpecInstSig ty _)
362 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
364 ppr_sig (FixSig fix_sig) = ppr fix_sig
367 instance Outputable name => Outputable (FixitySig name) where
368 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
370 ppr_phase :: Maybe Int -> SDoc
371 ppr_phase Nothing = empty
372 ppr_phase (Just n) = int n
375 Checking for distinct signatures; oh, so boring
379 eqHsSig :: Sig Name -> Sig Name -> Bool
380 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
381 eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2
382 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
384 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
385 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
386 = -- may have many specialisations for one value;
387 -- but not ones that are exactly the same...
388 (n1 == n2) && (ty1 == ty2)
390 eqHsSig other_1 other_2 = False