2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
6 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
9 #include "HsVersions.h"
16 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
17 IMPORT_DELOOPER(HsLoop) ( pprMatches, pprGRHSsAndBinds,
22 import HsPragmas ( GenPragmas, ClassOpPragmas )
23 import HsTypes ( HsType )
24 import CoreSyn ( SYN_IE(CoreExpr) )
27 import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId )
28 import Name ( OccName, NamedThing(..) )
29 import Outputable ( interpp'SP, ifnotPprForUser, pprQuote,
30 Outputable(..){-instance * (,)-}
32 import PprCore --( GenCoreExpr {- instance Outputable -} )
33 import PprType ( GenTyVar {- instance Outputable -} )
36 import SrcLoc ( SrcLoc{-instances-} )
37 import TyVar ( GenTyVar{-instances-} )
38 import Unique ( Unique {- instance Eq -} )
40 #if __GLASGOW_HASKELL__ >= 202
41 import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr )
42 import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds )
47 %************************************************************************
49 \subsection{Bindings: @HsBinds@}
51 %************************************************************************
53 The following syntax may produce new syntax which is not part of the input,
54 and which is instead a translation of the input to the typechecker.
55 Syntax translations are marked TRANSLATION in comments. New empty
56 productions are useful in development but may not appear in the final
59 Collections of bindings, created by dependency analysis and translation:
62 data HsBinds tyvar uvar id pat -- binders and bindees
65 | ThenBinds (HsBinds tyvar uvar id pat)
66 (HsBinds tyvar uvar id pat)
68 | MonoBind (MonoBinds tyvar uvar id pat)
69 [Sig id] -- Empty on typechecker output
78 nullBinds :: HsBinds tyvar uvar id pat -> Bool
80 nullBinds EmptyBinds = True
81 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
82 nullBinds (MonoBind b _ _) = nullMonoBinds b
86 instance (Outputable pat, NamedThing id, Outputable id,
87 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
88 Outputable (HsBinds tyvar uvar id pat) where
90 ppr sty binds = pprQuote sty (\ sty -> ppr_binds sty binds)
92 ppr_binds sty EmptyBinds = empty
93 ppr_binds sty (ThenBinds binds1 binds2)
94 = ($$) (ppr_binds sty binds1) (ppr_binds sty binds2)
95 ppr_binds sty (MonoBind bind sigs is_rec)
97 ifnotPprForUser sty (ptext rec_str),
100 else vcat (map (ppr sty) sigs),
104 rec_str | is_rec = SLIT("{- rec -}")
105 | otherwise = SLIT("{- nonrec -}")
108 %************************************************************************
110 \subsection{Bindings: @MonoBinds@}
112 %************************************************************************
114 Global bindings (where clauses)
117 data MonoBinds tyvar uvar id pat
120 | AndMonoBinds (MonoBinds tyvar uvar id pat)
121 (MonoBinds tyvar uvar id pat)
124 (GRHSsAndBinds tyvar uvar id pat)
128 Bool -- True => infix declaration
129 [Match tyvar uvar id pat] -- must have at least one Match
132 | VarMonoBind id -- TRANSLATION
133 (HsExpr tyvar uvar id pat)
135 | CoreMonoBind id -- TRANSLATION
136 CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
138 | AbsBinds -- Binds abstraction; TRANSLATION
139 [tyvar] -- Type variables
141 [([tyvar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
142 (MonoBinds tyvar uvar id pat) -- The "business end"
144 -- Creates bindings for *new* (polymorphic, overloaded) locals
145 -- in terms of *old* (monomorphic, non-overloaded) ones.
147 -- See section 9 of static semantics paper for more details.
148 -- (You can get a PhD for explaining the True Meaning
149 -- of this last construct.)
161 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
164 gp = ...same again, with gm instead of fm
166 This is a pretty bad translation, because it duplicates all the bindings.
167 So the desugarer tries to do a better job:
169 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
173 p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
177 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
179 nullMonoBinds EmptyMonoBinds = True
180 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
181 nullMonoBinds other_monobind = False
183 andMonoBinds :: [MonoBinds tyvar uvar id pat] -> MonoBinds tyvar uvar id pat
184 andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds
188 instance (NamedThing id, Outputable id, Outputable pat,
189 Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
190 Outputable (MonoBinds tyvar uvar id pat) where
191 ppr sty mbind = pprQuote sty (\ sty -> ppr_monobind sty mbind)
194 ppr_monobind sty EmptyMonoBinds = empty
195 ppr_monobind sty (AndMonoBinds binds1 binds2)
196 = ($$) (ppr_monobind sty binds1) (ppr_monobind sty binds2)
198 ppr_monobind sty (PatMonoBind pat grhss_n_binds locn)
199 = sep [ppr sty pat, nest 4 (pprGRHSsAndBinds sty False grhss_n_binds)]
201 ppr_monobind sty (FunMonoBind fun inf matches locn)
202 = pprMatches sty (False, ppr sty fun) matches
203 -- ToDo: print infix if appropriate
205 ppr_monobind sty (VarMonoBind name expr)
206 = sep [ppr sty name <+> equals, nest 4 (pprExpr sty expr)]
208 ppr_monobind sty (CoreMonoBind name expr)
209 = sep [ppr sty name <+> equals, nest 4 (ppr sty expr)]
211 ppr_monobind sty (AbsBinds tyvars dictvars exports val_binds)
212 = ($$) (sep [ptext SLIT("AbsBinds"),
213 brackets (interpp'SP sty tyvars),
214 brackets (interpp'SP sty dictvars),
215 brackets (interpp'SP sty exports)])
216 (nest 4 (ppr sty val_binds))
219 %************************************************************************
221 \subsection{@Sig@: type signatures and value-modifying user pragmas}
223 %************************************************************************
225 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
226 ``specialise this function to these four types...'') in with type
227 signatures. Then all the machinery to move them into place, etc.,
232 = Sig name -- a bog-std type signature
236 | ClassOpSig name -- Selector name
237 (Maybe name) -- Default-method name (if any)
241 | SpecSig name -- specialise a function or datatype ...
242 (HsType name) -- ... to these types
243 (Maybe name) -- ... maybe using this as the code for it
246 | InlineSig name -- INLINE f
250 name -- Associate the "name"d function with
251 FAST_STRING -- the compiler-builtin unfolding (known
252 SrcLoc -- by the String name)
256 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
257 ppr sty sig = pprQuote sty (\ sty -> ppr_sig sty sig)
260 ppr_sig sty (Sig var ty _)
261 = sep [ppr sty var <+> ptext SLIT("::"),
264 ppr_sig sty (ClassOpSig var _ ty _)
265 = sep [ppr sty (getOccName var) <+> ptext SLIT("::"),
268 ppr_sig sty (SpecSig var ty using _)
269 = sep [ hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")],
270 nest 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
273 pp_using Nothing = empty
274 pp_using (Just me) = hsep [char '=', ppr sty me]
276 ppr_sig sty (InlineSig var _)
277 = hsep [text "{-# INLINE", ppr sty var, text "#-}"]
279 ppr_sig sty (MagicUnfoldingSig var str _)
280 = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"]