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 )
30 %************************************************************************
32 \subsection{Bindings: @HsBinds@}
34 %************************************************************************
36 The following syntax may produce new syntax which is not part of the input,
37 and which is instead a translation of the input to the typechecker.
38 Syntax translations are marked TRANSLATION in comments. New empty
39 productions are useful in development but may not appear in the final
42 Collections of bindings, created by dependency analysis and translation:
45 data HsBinds id pat -- binders and bindees
48 | ThenBinds (HsBinds id pat)
51 | MonoBind (MonoBinds id pat)
52 [Sig id] -- Empty on typechecker output
57 nullBinds :: HsBinds id pat -> Bool
59 nullBinds EmptyBinds = True
60 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
61 nullBinds (MonoBind b _ _) = nullMonoBinds b
63 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
64 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
65 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
69 instance (Outputable pat, Outputable id) =>
70 Outputable (HsBinds id pat) where
71 ppr binds = ppr_binds binds
73 ppr_binds EmptyBinds = empty
74 ppr_binds (ThenBinds binds1 binds2)
75 = ($$) (ppr_binds binds1) (ppr_binds binds2)
76 ppr_binds (MonoBind bind sigs is_rec)
77 = vcat [ifNotPprForUser (ptext rec_str),
82 rec_str = case is_rec of
83 Recursive -> SLIT("{- rec -}")
84 NonRecursive -> SLIT("{- nonrec -}")
87 %************************************************************************
89 \subsection{Bindings: @MonoBinds@}
91 %************************************************************************
93 Global bindings (where clauses)
99 | AndMonoBinds (MonoBinds id pat)
102 | FunMonoBind id -- Used for both functions f x = e
103 -- and variables f = \x -> e
104 -- Reason: the Match stuff lets us have an optional
105 -- result type sig f :: a->a = ...mentions a...
106 Bool -- True => infix declaration
110 | PatMonoBind pat -- The pattern is never a simple variable;
111 -- That case is done by FunMonoBind
115 | VarMonoBind id -- TRANSLATION
118 | CoreMonoBind id -- TRANSLATION
119 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
121 | AbsBinds -- Binds abstraction; TRANSLATION
122 [TyVar] -- Type variables
124 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
125 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
126 (MonoBinds id pat) -- The "business end"
128 -- Creates bindings for *new* (polymorphic, overloaded) locals
129 -- in terms of *old* (monomorphic, non-overloaded) ones.
131 -- See section 9 of static semantics paper for more details.
132 -- (You can get a PhD for explaining the True Meaning
133 -- of this last construct.)
145 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
148 gp = ...same again, with gm instead of fm
150 This is a pretty bad translation, because it duplicates all the bindings.
151 So the desugarer tries to do a better job:
153 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
157 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
161 -- We keep the invariant that a MonoBinds is only empty
162 -- if it is exactly EmptyMonoBinds
164 nullMonoBinds :: MonoBinds id pat -> Bool
165 nullMonoBinds EmptyMonoBinds = True
166 nullMonoBinds other_monobind = False
168 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
169 andMonoBinds EmptyMonoBinds mb = mb
170 andMonoBinds mb EmptyMonoBinds = mb
171 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
173 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
174 andMonoBindList binds
177 loop1 [] = EmptyMonoBinds
178 loop1 (EmptyMonoBinds : binds) = loop1 binds
179 loop1 (b:bs) = loop2 b bs
183 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
184 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
189 instance (Outputable id, Outputable pat) =>
190 Outputable (MonoBinds id pat) where
191 ppr mbind = ppr_monobind mbind
194 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
195 ppr_monobind EmptyMonoBinds = empty
196 ppr_monobind (AndMonoBinds binds1 binds2)
197 = ppr_monobind binds1 $$ ppr_monobind binds2
199 ppr_monobind (PatMonoBind pat grhss locn)
200 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
202 ppr_monobind (FunMonoBind fun inf matches locn)
203 = pprMatches (False, ppr fun) matches
204 -- ToDo: print infix if appropriate
206 ppr_monobind (VarMonoBind name expr)
207 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
209 ppr_monobind (CoreMonoBind name expr)
210 = sep [ppr name <+> equals, nest 4 (ppr expr)]
212 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
213 = sep [ptext SLIT("AbsBinds"),
214 brackets (interpp'SP tyvars),
215 brackets (interpp'SP dictvars),
216 brackets (sep (punctuate comma (map ppr exports))),
217 brackets (interpp'SP (nameSetToList inlines))]
219 nest 4 (ppr val_binds)
222 %************************************************************************
224 \subsection{@Sig@: type signatures and value-modifying user pragmas}
226 %************************************************************************
228 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
229 ``specialise this function to these four types...'') in with type
230 signatures. Then all the machinery to move them into place, etc.,
235 = Sig name -- a bog-std type signature
239 | ClassOpSig name -- Selector name
240 (Maybe -- Nothing for source-file class signatures
241 (name, -- Default-method name (if any)
242 Bool)) -- True <=> there is an explicit, programmer-supplied
243 -- default declaration in the class decl
247 | SpecSig name -- specialise a function or datatype ...
248 (HsType name) -- ... to these types
251 | InlineSig name -- INLINE f
255 | NoInlineSig name -- NOINLINE f
259 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
260 -- current instance decl
263 | FixSig (FixitySig name) -- Fixity declaration
266 data FixitySig name = FixitySig name Fixity SrcLoc
268 instance Eq name => Eq (FixitySig name) where
269 (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
273 okBindSig :: NameSet -> Sig Name -> Bool
274 okBindSig ns (ClassOpSig _ _ _ _) = False
275 okBindSig ns sig = sigForThisGroup ns sig
277 okClsDclSig :: NameSet -> Sig Name -> Bool
278 okClsDclSig ns (Sig _ _ _) = False
279 okClsDclSig ns sig = sigForThisGroup ns sig
281 okInstDclSig :: NameSet -> Sig Name -> Bool
282 okInstDclSig ns (Sig _ _ _) = False
283 okInstDclSig ns (FixSig _) = False
284 okInstDclSig ns (SpecInstSig _ _) = True
285 okInstDclSig ns sig = sigForThisGroup ns sig
287 sigForThisGroup ns sig
288 = case sigName sig of
290 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
291 | otherwise -> n `elemNameSet` ns
293 sigName :: Sig name -> Maybe name
294 sigName (Sig n _ _) = Just n
295 sigName (ClassOpSig n _ _ _) = Just n
296 sigName (SpecSig n _ _) = Just n
297 sigName (InlineSig n _ _) = Just n
298 sigName (NoInlineSig n _ _) = Just n
299 sigName (FixSig (FixitySig n _ _)) = Just n
300 sigName other = Nothing
302 isFixitySig :: Sig name -> Bool
303 isFixitySig (FixSig _) = True
304 isFixitySig _ = False
306 isClassOpSig :: Sig name -> Bool
307 isClassOpSig (ClassOpSig _ _ _ _) = True
308 isClassOpSig _ = False
310 isPragSig :: Sig name -> Bool
311 -- Identifies pragmas
312 isPragSig (SpecSig _ _ _) = True
313 isPragSig (InlineSig _ _ _) = True
314 isPragSig (NoInlineSig _ _ _) = 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 _ _ loc) = (SLIT("INLINE pragma"),loc)
324 hsSigDoc (NoInlineSig _ _ 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 <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
341 Just (_, True) -> equals -- Default-method indicator
344 ppr_sig (SpecSig var ty _)
345 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
346 nest 4 (ppr ty <+> text "#-}")
349 ppr_sig (InlineSig var phase _)
350 = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
352 ppr_sig (NoInlineSig var phase _)
353 = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
355 ppr_sig (SpecInstSig ty _)
356 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
358 ppr_sig (FixSig fix_sig) = ppr fix_sig
361 instance Outputable name => Outputable (FixitySig name) where
362 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
364 ppr_phase :: Maybe Int -> SDoc
365 ppr_phase Nothing = empty
366 ppr_phase (Just n) = int n
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 n1 _ _) (InlineSig n2 _ _) = n1 == n2
376 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
378 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
379 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
380 = -- may have many specialisations for one value;
381 -- but not ones that are exactly the same...
382 (n1 == n2) && (ty1 == ty2)
384 eqHsSig other_1 other_2 = False