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) -- Default-method info
245 -- See "THE NAMING STORY" in HsDecls
249 | SpecSig name -- specialise a function or datatype ...
250 (HsType name) -- ... to these types
253 | InlineSig name -- INLINE f
257 | NoInlineSig name -- NOINLINE f
261 | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
262 -- current instance decl
265 | FixSig (FixitySig name) -- Fixity declaration
268 data FixitySig name = FixitySig name Fixity SrcLoc
270 instance Eq name => Eq (FixitySig name) where
271 (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
275 okBindSig :: NameSet -> Sig Name -> Bool
276 okBindSig ns (ClassOpSig _ _ _ _) = False
277 okBindSig ns sig = sigForThisGroup ns sig
279 okClsDclSig :: NameSet -> Sig Name -> Bool
280 okClsDclSig ns (Sig _ _ _) = False
281 okClsDclSig ns sig = sigForThisGroup ns sig
283 okInstDclSig :: NameSet -> Sig Name -> Bool
284 okInstDclSig ns (Sig _ _ _) = False
285 okInstDclSig ns (FixSig _) = False
286 okInstDclSig ns (SpecInstSig _ _) = True
287 okInstDclSig ns sig = sigForThisGroup ns sig
289 sigForThisGroup ns sig
290 = case sigName sig of
292 Just n | isUnboundName n -> True -- Don't complain about an unbound name again
293 | otherwise -> n `elemNameSet` ns
295 sigName :: Sig name -> Maybe name
296 sigName (Sig n _ _) = Just n
297 sigName (ClassOpSig n _ _ _) = Just n
298 sigName (SpecSig n _ _) = Just n
299 sigName (InlineSig n _ _) = Just n
300 sigName (NoInlineSig n _ _) = Just n
301 sigName (FixSig (FixitySig n _ _)) = Just n
302 sigName other = Nothing
304 isFixitySig :: Sig name -> Bool
305 isFixitySig (FixSig _) = True
306 isFixitySig _ = False
308 isClassOpSig :: Sig name -> Bool
309 isClassOpSig (ClassOpSig _ _ _ _) = True
310 isClassOpSig _ = False
312 isPragSig :: Sig name -> Bool
313 -- Identifies pragmas
314 isPragSig (SpecSig _ _ _) = True
315 isPragSig (InlineSig _ _ _) = True
316 isPragSig (NoInlineSig _ _ _) = True
317 isPragSig (SpecInstSig _ _) = True
318 isPragSig other = False
322 hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
323 hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
324 hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
325 hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
326 hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
327 hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
328 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
332 instance (Outputable name) => Outputable (Sig name) where
333 ppr sig = ppr_sig sig
335 ppr_sig :: Outputable name => Sig name -> SDoc
336 ppr_sig (Sig var ty _)
337 = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
339 ppr_sig (ClassOpSig var dm ty _)
340 = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
343 DefMeth _ -> equals -- Default method indicator
344 GenDefMeth -> semi -- Generic method indicator
345 NoDefMeth -> empty -- No Method at all
347 ppr_sig (SpecSig var ty _)
348 = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
349 nest 4 (ppr ty <+> text "#-}")
352 ppr_sig (InlineSig var phase _)
353 = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
355 ppr_sig (NoInlineSig var phase _)
356 = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
358 ppr_sig (SpecInstSig ty _)
359 = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
361 ppr_sig (FixSig fix_sig) = ppr fix_sig
364 instance Outputable name => Outputable (FixitySig name) where
365 ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
367 ppr_phase :: Maybe Int -> SDoc
368 ppr_phase Nothing = empty
369 ppr_phase (Just n) = int n
372 Checking for distinct signatures; oh, so boring
376 eqHsSig :: Sig Name -> Sig Name -> Bool
377 eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
378 eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2
379 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
381 eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
382 eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
383 = -- may have many specialisations for one value;
384 -- but not ones that are exactly the same...
385 (n1 == n2) && (ty1 == ty2)
387 eqHsSig other_1 other_2 = False