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 ( {- instance Outputable (Expr a) -} )
23 import PrelNames ( isUnboundName )
24 import NameSet ( NameSet, elemNameSet, nameSetToList )
25 import BasicTypes ( RecFlag(..), Fixity )
27 import SrcLoc ( SrcLoc )
29 import Class ( DefMeth (..) )
32 %************************************************************************
34 \subsection{Bindings: @HsBinds@}
36 %************************************************************************
38 The following syntax may produce new syntax which is not part of the input,
39 and which is instead a translation of the input to the typechecker.
40 Syntax translations are marked TRANSLATION in comments. New empty
41 productions are useful in development but may not appear in the final
44 Collections of bindings, created by dependency analysis and translation:
47 data HsBinds id pat -- binders and bindees
50 | ThenBinds (HsBinds id pat)
53 | MonoBind (MonoBinds id pat)
54 [Sig id] -- Empty on typechecker output
59 nullBinds :: HsBinds id pat -> Bool
61 nullBinds EmptyBinds = True
62 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
63 nullBinds (MonoBind b _ _) = nullMonoBinds b
65 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
66 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
67 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
71 instance (Outputable pat, Outputable id) =>
72 Outputable (HsBinds id pat) where
73 ppr binds = ppr_binds binds
75 ppr_binds EmptyBinds = empty
76 ppr_binds (ThenBinds binds1 binds2)
77 = ppr_binds binds1 $$ ppr_binds binds2
78 ppr_binds (MonoBind bind sigs is_rec)
84 ppr_isrec = getPprStyle $ \ sty ->
85 if userStyle sty then empty else
87 Recursive -> ptext SLIT("{- rec -}")
88 NonRecursive -> ptext SLIT("{- nonrec -}")
91 %************************************************************************
93 \subsection{Bindings: @MonoBinds@}
95 %************************************************************************
97 Global bindings (where clauses)
100 data MonoBinds id pat
103 | AndMonoBinds (MonoBinds id pat)
106 | FunMonoBind id -- Used for both functions f x = e
107 -- and variables f = \x -> e
108 -- Reason: the Match stuff lets us have an optional
109 -- result type sig f :: a->a = ...mentions a...
110 Bool -- True => infix declaration
114 | PatMonoBind pat -- The pattern is never a simple variable;
115 -- That case is done by FunMonoBind
119 | VarMonoBind id -- TRANSLATION
122 | CoreMonoBind id -- TRANSLATION
123 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
125 | AbsBinds -- Binds abstraction; TRANSLATION
126 [TyVar] -- Type variables
128 [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
129 NameSet -- Set of *polymorphic* variables that have an INLINE pragma
130 (MonoBinds id pat) -- The "business end"
132 -- Creates bindings for *new* (polymorphic, overloaded) locals
133 -- in terms of *old* (monomorphic, non-overloaded) ones.
135 -- See section 9 of static semantics paper for more details.
136 -- (You can get a PhD for explaining the True Meaning
137 -- of this last construct.)
149 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
152 gp = ...same again, with gm instead of fm
154 This is a pretty bad translation, because it duplicates all the bindings.
155 So the desugarer tries to do a better job:
157 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
161 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
165 -- We keep the invariant that a MonoBinds is only empty
166 -- if it is exactly EmptyMonoBinds
168 nullMonoBinds :: MonoBinds id pat -> Bool
169 nullMonoBinds EmptyMonoBinds = True
170 nullMonoBinds other_monobind = False
172 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
173 andMonoBinds EmptyMonoBinds mb = mb
174 andMonoBinds mb EmptyMonoBinds = mb
175 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
177 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
178 andMonoBindList binds
181 loop1 [] = EmptyMonoBinds
182 loop1 (EmptyMonoBinds : binds) = loop1 binds
183 loop1 (b:bs) = loop2 b bs
187 loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
188 loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
193 instance (Outputable id, Outputable pat) =>
194 Outputable (MonoBinds id pat) where
195 ppr mbind = ppr_monobind mbind
198 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
199 ppr_monobind EmptyMonoBinds = empty
200 ppr_monobind (AndMonoBinds binds1 binds2)
201 = ppr_monobind binds1 $$ ppr_monobind binds2
203 ppr_monobind (PatMonoBind pat grhss locn)
204 = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
206 ppr_monobind (FunMonoBind fun inf matches locn)
207 = pprMatches (False, ppr fun) matches
208 -- ToDo: print infix if appropriate
210 ppr_monobind (VarMonoBind name expr)
211 = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
213 ppr_monobind (CoreMonoBind name expr)
214 = sep [ppr name <+> equals, nest 4 (ppr expr)]
216 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
217 = sep [ptext SLIT("AbsBinds"),
218 brackets (interpp'SP tyvars),
219 brackets (interpp'SP dictvars),
220 brackets (sep (punctuate comma (map ppr exports))),
221 brackets (interpp'SP (nameSetToList inlines))]
223 nest 4 (ppr val_binds)
226 %************************************************************************
228 \subsection{@Sig@: type signatures and value-modifying user pragmas}
230 %************************************************************************
232 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
233 ``specialise this function to these four types...'') in with type
234 signatures. Then all the machinery to move them into place, etc.,
239 = Sig name -- a bog-std type signature
243 | ClassOpSig name -- Selector name
244 (DefMeth name) -- (Just dm_name) for source-file class signatures
245 -- The name may not be used, if there isn't a
246 -- generic default method, but it's there if we
248 -- Gives DefMeth info for interface files sigs
252 | SpecSig name -- specialise a function or datatype ...
253 (HsType name) -- ... to these types
256 | InlineSig name -- INLINE f
260 | NoInlineSig name -- NOINLINE f
264 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
265 -- current instance decl
268 | FixSig (FixitySig name) -- Fixity declaration
271 data FixitySig name = FixitySig name Fixity SrcLoc
273 instance Eq name => Eq (FixitySig name) where
274 (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
278 okBindSig :: NameSet -> Sig Name -> Bool
279 okBindSig ns (ClassOpSig _ _ _ _) = False
280 okBindSig ns sig = sigForThisGroup ns sig
282 okClsDclSig :: NameSet -> Sig Name -> Bool
283 okClsDclSig ns (Sig _ _ _) = False
284 okClsDclSig ns sig = sigForThisGroup ns sig
286 okInstDclSig :: NameSet -> Sig Name -> Bool
287 okInstDclSig ns (Sig _ _ _) = False
288 okInstDclSig ns (FixSig _) = False
289 okInstDclSig ns (SpecInstSig _ _) = True
290 okInstDclSig ns sig = sigForThisGroup ns sig
292 sigForThisGroup ns sig
293 = case sigName sig of
295 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
296 | otherwise -> n `elemNameSet` ns
298 sigName :: Sig name -> Maybe name
299 sigName (Sig n _ _) = Just n
300 sigName (ClassOpSig n _ _ _) = Just n
301 sigName (SpecSig n _ _) = Just n
302 sigName (InlineSig n _ _) = Just n
303 sigName (NoInlineSig n _ _) = Just n
304 sigName (FixSig (FixitySig n _ _)) = Just n
305 sigName other = Nothing
307 isFixitySig :: Sig name -> Bool
308 isFixitySig (FixSig _) = True
309 isFixitySig _ = False
311 isClassOpSig :: Sig name -> Bool
312 isClassOpSig (ClassOpSig _ _ _ _) = True
313 isClassOpSig _ = False
315 isPragSig :: Sig name -> Bool
316 -- Identifies pragmas
317 isPragSig (SpecSig _ _ _) = True
318 isPragSig (InlineSig _ _ _) = True
319 isPragSig (NoInlineSig _ _ _) = True
320 isPragSig (SpecInstSig _ _) = True
321 isPragSig other = False
325 hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
326 hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
327 hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
328 hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
329 hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
330 hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
331 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
335 instance (Outputable name) => Outputable (Sig name) where
336 ppr sig = ppr_sig sig
338 ppr_sig :: Outputable name => Sig name -> SDoc
339 ppr_sig (Sig var ty _)
340 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
342 ppr_sig (ClassOpSig var dm ty _)
343 = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
346 DefMeth _ -> equals -- Default method indicator
347 GenDefMeth -> semi -- Generic method indicator
348 NoDefMeth -> 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