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 ( HsExpr, pprExpr,
18 import HsTypes ( HsType )
19 import CoreSyn ( CoreExpr )
20 import PprCore ( {- instance Outputable (Expr a) -} )
24 import PrelNames ( isUnboundName )
25 import NameSet ( NameSet, elemNameSet, nameSetToList )
26 import BasicTypes ( RecFlag(..), Fixity )
28 import SrcLoc ( SrcLoc )
30 import Class ( DefMeth (..) )
33 %************************************************************************
35 \subsection{Bindings: @HsBinds@}
37 %************************************************************************
39 The following syntax may produce new syntax which is not part of the input,
40 and which is instead a translation of the input to the typechecker.
41 Syntax translations are marked TRANSLATION in comments. New empty
42 productions are useful in development but may not appear in the final
45 Collections of bindings, created by dependency analysis and translation:
48 data HsBinds id pat -- binders and bindees
51 | ThenBinds (HsBinds id pat)
54 | MonoBind (MonoBinds id pat)
55 [Sig id] -- Empty on typechecker output
60 nullBinds :: HsBinds id pat -> Bool
62 nullBinds EmptyBinds = True
63 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
64 nullBinds (MonoBind b _ _) = nullMonoBinds b
66 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
67 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
68 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
72 instance (Outputable pat, Outputable id) =>
73 Outputable (HsBinds id pat) where
74 ppr binds = ppr_binds binds
76 ppr_binds EmptyBinds = empty
77 ppr_binds (ThenBinds binds1 binds2)
78 = ppr_binds binds1 $$ ppr_binds binds2
79 ppr_binds (MonoBind bind sigs is_rec)
85 ppr_isrec = getPprStyle $ \ sty ->
86 if userStyle sty then empty else
88 Recursive -> ptext SLIT("{- rec -}")
89 NonRecursive -> ptext SLIT("{- nonrec -}")
92 %************************************************************************
94 \subsection{Bindings: @MonoBinds@}
96 %************************************************************************
98 Global bindings (where clauses)
101 data MonoBinds id pat
104 | AndMonoBinds (MonoBinds id pat)
107 | FunMonoBind id -- Used for both functions f x = e
108 -- and variables f = \x -> e
109 -- Reason: the Match stuff lets us have an optional
110 -- result type sig f :: a->a = ...mentions a...
111 Bool -- True => infix declaration
115 | PatMonoBind pat -- The pattern is never a simple variable;
116 -- That case is done by FunMonoBind
120 | VarMonoBind id -- TRANSLATION
123 | CoreMonoBind id -- TRANSLATION
124 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
126 | AbsBinds -- Binds abstraction; TRANSLATION
127 [TyVar] -- Type variables
129 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
130 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
131 (MonoBinds id pat) -- The "business end"
133 -- Creates bindings for *new* (polymorphic, overloaded) locals
134 -- in terms of *old* (monomorphic, non-overloaded) ones.
136 -- See section 9 of static semantics paper for more details.
137 -- (You can get a PhD for explaining the True Meaning
138 -- of this last construct.)
150 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
153 gp = ...same again, with gm instead of fm
155 This is a pretty bad translation, because it duplicates all the bindings.
156 So the desugarer tries to do a better job:
158 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
162 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
166 -- We keep the invariant that a MonoBinds is only empty
167 -- if it is exactly EmptyMonoBinds
169 nullMonoBinds :: MonoBinds id pat -> Bool
170 nullMonoBinds EmptyMonoBinds = True
171 nullMonoBinds other_monobind = False
173 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
174 andMonoBinds EmptyMonoBinds mb = mb
175 andMonoBinds mb EmptyMonoBinds = mb
176 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
178 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
179 andMonoBindList binds
182 loop1 [] = EmptyMonoBinds
183 loop1 (EmptyMonoBinds : binds) = loop1 binds
184 loop1 (b:bs) = loop2 b bs
188 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
189 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
194 instance (Outputable id, Outputable pat) =>
195 Outputable (MonoBinds id pat) where
196 ppr mbind = ppr_monobind mbind
199 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
200 ppr_monobind EmptyMonoBinds = empty
201 ppr_monobind (AndMonoBinds binds1 binds2)
202 = ppr_monobind binds1 $$ ppr_monobind binds2
204 ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
205 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
206 -- ToDo: print infix if appropriate
208 ppr_monobind (VarMonoBind name expr)
209 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
211 ppr_monobind (CoreMonoBind name expr)
212 = sep [ppr name <+> equals, nest 4 (ppr expr)]
214 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
215 = sep [ptext SLIT("AbsBinds"),
216 brackets (interpp'SP tyvars),
217 brackets (interpp'SP dictvars),
218 brackets (sep (punctuate comma (map ppr exports))),
219 brackets (interpp'SP (nameSetToList inlines))]
221 nest 4 (ppr val_binds)
224 %************************************************************************
226 \subsection{@Sig@: type signatures and value-modifying user pragmas}
228 %************************************************************************
230 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
231 ``specialise this function to these four types...'') in with type
232 signatures. Then all the machinery to move them into place, etc.,
237 = Sig name -- a bog-std type signature
241 | ClassOpSig name -- Selector name
242 (DefMeth name) -- Default-method info
243 -- See "THE NAMING STORY" in HsDecls
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 DefMeth _ -> equals -- Default method indicator
342 GenDefMeth -> semi -- Generic method indicator
343 NoDefMeth -> empty -- No Method at all
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 _other1 _other2 = False