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, pprMatches, Match, pprGRHSs, GRHSs )
16 import HsTypes ( HsType )
17 import CoreSyn ( CoreExpr )
18 import PprCore ( {- instance Outputable (Expr a) -} )
22 import PrelNames ( 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)
83 ppr_isrec = getPprStyle $ \ sty ->
84 if userStyle sty then empty else
86 Recursive -> ptext SLIT("{- rec -}")
87 NonRecursive -> ptext SLIT("{- nonrec -}")
90 %************************************************************************
92 \subsection{Bindings: @MonoBinds@}
94 %************************************************************************
96 Global bindings (where clauses)
102 | AndMonoBinds (MonoBinds id pat)
105 | FunMonoBind id -- Used for both functions f x = e
106 -- and variables f = \x -> e
107 -- Reason: the Match stuff lets us have an optional
108 -- result type sig f :: a->a = ...mentions a...
109 Bool -- True => infix declaration
113 | PatMonoBind pat -- The pattern is never a simple variable;
114 -- That case is done by FunMonoBind
118 | VarMonoBind id -- TRANSLATION
121 | CoreMonoBind id -- TRANSLATION
122 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
124 | AbsBinds -- Binds abstraction; TRANSLATION
125 [TyVar] -- Type variables
127 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
128 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
129 (MonoBinds id pat) -- The "business end"
131 -- Creates bindings for *new* (polymorphic, overloaded) locals
132 -- in terms of *old* (monomorphic, non-overloaded) ones.
134 -- See section 9 of static semantics paper for more details.
135 -- (You can get a PhD for explaining the True Meaning
136 -- of this last construct.)
148 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
151 gp = ...same again, with gm instead of fm
153 This is a pretty bad translation, because it duplicates all the bindings.
154 So the desugarer tries to do a better job:
156 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
160 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
164 -- We keep the invariant that a MonoBinds is only empty
165 -- if it is exactly EmptyMonoBinds
167 nullMonoBinds :: MonoBinds id pat -> Bool
168 nullMonoBinds EmptyMonoBinds = True
169 nullMonoBinds other_monobind = False
171 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
172 andMonoBinds EmptyMonoBinds mb = mb
173 andMonoBinds mb EmptyMonoBinds = mb
174 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
176 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
177 andMonoBindList binds
180 loop1 [] = EmptyMonoBinds
181 loop1 (EmptyMonoBinds : binds) = loop1 binds
182 loop1 (b:bs) = loop2 b bs
186 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
187 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
192 instance (Outputable id, Outputable pat) =>
193 Outputable (MonoBinds id pat) where
194 ppr mbind = ppr_monobind mbind
197 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
198 ppr_monobind EmptyMonoBinds = empty
199 ppr_monobind (AndMonoBinds binds1 binds2)
200 = ppr_monobind binds1 $$ ppr_monobind binds2
202 ppr_monobind (PatMonoBind pat grhss locn)
203 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
205 ppr_monobind (FunMonoBind fun inf matches locn)
206 = pprMatches (False, ppr fun) matches
207 -- ToDo: print infix if appropriate
209 ppr_monobind (VarMonoBind name expr)
210 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
212 ppr_monobind (CoreMonoBind name expr)
213 = sep [ppr name <+> equals, nest 4 (ppr expr)]
215 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
216 = sep [ptext SLIT("AbsBinds"),
217 brackets (interpp'SP tyvars),
218 brackets (interpp'SP dictvars),
219 brackets (sep (punctuate comma (map ppr exports))),
220 brackets (interpp'SP (nameSetToList inlines))]
222 nest 4 (ppr val_binds)
225 %************************************************************************
227 \subsection{@Sig@: type signatures and value-modifying user pragmas}
229 %************************************************************************
231 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
232 ``specialise this function to these four types...'') in with type
233 signatures. Then all the machinery to move them into place, etc.,
238 = Sig name -- a bog-std type signature
242 | ClassOpSig name -- Selector name
243 (DefMeth name) -- Default-method info
244 -- See "THE NAMING STORY" in HsDecls
248 | SpecSig name -- specialise a function or datatype ...
249 (HsType name) -- ... to these types
252 | InlineSig name -- INLINE f
256 | NoInlineSig name -- NOINLINE f
260 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
261 -- current instance decl
264 | FixSig (FixitySig name) -- Fixity declaration
267 data FixitySig name = FixitySig name Fixity SrcLoc
269 instance Eq name => Eq (FixitySig name) where
270 (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
274 okBindSig :: NameSet -> Sig Name -> Bool
275 okBindSig ns (ClassOpSig _ _ _ _) = False
276 okBindSig ns sig = sigForThisGroup ns sig
278 okClsDclSig :: NameSet -> Sig Name -> Bool
279 okClsDclSig ns (Sig _ _ _) = False
280 okClsDclSig ns sig = sigForThisGroup ns sig
282 okInstDclSig :: NameSet -> Sig Name -> Bool
283 okInstDclSig ns (Sig _ _ _) = False
284 okInstDclSig ns (FixSig _) = False
285 okInstDclSig ns (SpecInstSig _ _) = True
286 okInstDclSig ns sig = sigForThisGroup ns sig
288 sigForThisGroup ns sig
289 = case sigName sig of
291 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
292 | otherwise -> n `elemNameSet` ns
294 sigName :: Sig name -> Maybe name
295 sigName (Sig n _ _) = Just n
296 sigName (ClassOpSig n _ _ _) = Just n
297 sigName (SpecSig n _ _) = Just n
298 sigName (InlineSig n _ _) = Just n
299 sigName (NoInlineSig 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 (NoInlineSig _ _ _) = True
316 isPragSig (SpecInstSig _ _) = True
317 isPragSig other = False
321 hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
322 hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
323 hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
324 hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
325 hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
326 hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
327 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
331 instance (Outputable name) => Outputable (Sig name) where
332 ppr sig = ppr_sig sig
334 ppr_sig :: Outputable name => Sig name -> SDoc
335 ppr_sig (Sig var ty _)
336 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
338 ppr_sig (ClassOpSig var dm ty _)
339 = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
342 DefMeth _ -> equals -- Default method indicator
343 GenDefMeth -> semi -- Generic method indicator
344 NoDefMeth -> empty -- No Method at all
346 ppr_sig (SpecSig var ty _)
347 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
348 nest 4 (ppr ty <+> text "#-}")
351 ppr_sig (InlineSig var phase _)
352 = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
354 ppr_sig (NoInlineSig var phase _)
355 = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
357 ppr_sig (SpecInstSig ty _)
358 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
360 ppr_sig (FixSig fix_sig) = ppr fix_sig
363 instance Outputable name => Outputable (FixitySig name) where
364 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
366 ppr_phase :: Maybe Int -> SDoc
367 ppr_phase Nothing = empty
368 ppr_phase (Just n) = int n
371 Checking for distinct signatures; oh, so boring
375 eqHsSig :: Sig Name -> Sig Name -> Bool
376 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
377 eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2
378 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = 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