69b75b428c853b4a43580a646ff0ff04ba8b7221
[ghc-hetmet.git] / ghc / compiler / hsSyn / HsBinds.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
5
6 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
7
8 \begin{code}
9 module HsBinds where
10
11 #include "HsVersions.h"
12
13 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
14                                MatchGroup, pprFunBind,
15                                GRHSs, pprPatBind )
16 import {-# SOURCE #-} HsPat  ( LPat )
17
18 import HsTypes          ( LHsType, PostTcType )
19 import Type             ( Type )
20 import Name             ( Name )
21 import NameSet          ( NameSet, elemNameSet )
22 import BasicTypes       ( IPName, RecFlag(..), InlineSpec(..), Fixity )
23 import Outputable       
24 import SrcLoc           ( Located(..), SrcSpan, unLoc )
25 import Util             ( sortLe )
26 import Var              ( TyVar, DictId, Id )
27 import Bag              ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
28 \end{code}
29
30 %************************************************************************
31 %*                                                                      *
32 \subsection{Bindings: @BindGroup@}
33 %*                                                                      *
34 %************************************************************************
35
36 Global bindings (where clauses)
37
38 \begin{code}
39 data HsLocalBinds id    -- Bindings in a 'let' expression
40                         -- or a 'where' clause
41   = HsValBinds (HsValBinds id)
42   | HsIPBinds  (HsIPBinds id)
43   | EmptyLocalBinds
44
45 data HsValBinds id      -- Value bindings (not implicit parameters)
46   = ValBindsIn                          -- Before typechecking
47         (LHsBinds id) [LSig id]         -- Not dependency analysed
48                                         -- Recursive by default
49
50   | ValBindsOut                         -- After renaming
51         [(RecFlag, LHsBinds id)]        -- Dependency analysed
52         [LSig Name]
53
54 type LHsBinds id  = Bag (LHsBind id)
55 type DictBinds id = LHsBinds id         -- Used for dictionary or method bindings
56 type LHsBind  id  = Located (HsBind id)
57
58 data HsBind id
59   = FunBind {   -- FunBind is used for both functions   f x = e
60                 -- and variables                        f = \x -> e
61 -- Reason 1: the Match stuff lets us have an optional
62 --         result type sig      f :: a->a = ...mentions a...
63 --
64 -- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds
65 --
66 -- Reason 3: instance decls can only have FunBinds, which is convenient
67 --           If you change this, you'll need tochange e.g. rnMethodBinds
68
69         fun_id :: Located id,
70
71         fun_infix :: Bool,      -- True => infix declaration
72
73         fun_matches :: MatchGroup id,   -- The payload
74
75         fun_co_fn :: ExprCoFn,  -- Coercion from the type of the MatchGroup to the type of
76                                 -- the Id.  Example:
77                                 --      f :: Int -> forall a. a -> a
78                                 --      f x y = y
79                                 -- Then the MatchGroup will have type (Int -> a' -> a')
80                                 -- (with a free type variable a').  The coercion will take
81                                 -- a CoreExpr of this type and convert it to a CoreExpr of
82                                 -- type         Int -> forall a'. a' -> a'
83                                 -- Notice that the coercion captures the free a'.  That's
84                                 -- why coercions are (CoreExpr -> CoreExpr), rather than
85                                 -- just CoreExpr (with a functional type)
86
87         bind_fvs :: NameSet     -- After the renamer, this contains a superset of the 
88                                 -- Names of the other binders in this binding group that 
89                                 -- are free in the RHS of the defn
90                                 -- Before renaming, and after typechecking, 
91                                 -- the field is unused; it's just an error thunk
92     }
93
94   | PatBind {   -- The pattern is never a simple variable;
95                 -- That case is done by FunBind
96         pat_lhs    :: LPat id,
97         pat_rhs    :: GRHSs id,
98         pat_rhs_ty :: PostTcType,       -- Type of the GRHSs
99         bind_fvs   :: NameSet           -- Same as for FunBind
100     }
101
102   | VarBind {   -- Dictionary binding and suchlike 
103         var_id :: id,           -- All VarBinds are introduced by the type checker
104         var_rhs :: LHsExpr id   -- Located only for consistency
105     }
106
107   | AbsBinds {                                  -- Binds abstraction; TRANSLATION
108         abs_tvs     :: [TyVar],  
109         abs_dicts   :: [DictId],
110         abs_exports :: [([TyVar], id, id, [Prag])],     -- (tvs, poly_id, mono_id, prags)
111         abs_binds   :: LHsBinds id              -- The dictionary bindings and typechecked user bindings
112                                                 -- mixed up together; you can tell the dict bindings because
113                                                 -- they are all VarBinds
114     }
115         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
116         -- 
117         -- Creates bindings for (polymorphic, overloaded) poly_f
118         -- in terms of monomorphic, non-overloaded mono_f
119         --
120         -- Invariants: 
121         --      1. 'binds' binds mono_f
122         --      2. ftvs is a subset of tvs
123         --      3. ftvs includes all tyvars free in ds
124         --
125         -- See section 9 of static semantics paper for more details.
126         -- (You can get a PhD for explaining the True Meaning
127         --  of this last construct.)
128
129 placeHolderNames :: NameSet
130 -- Used for the NameSet in FunBind and PatBind prior to the renamer
131 placeHolderNames = panic "placeHolderNames"
132
133 ------------
134 instance OutputableBndr id => Outputable (HsLocalBinds id) where
135   ppr (HsValBinds bs) = ppr bs
136   ppr (HsIPBinds bs)  = ppr bs
137   ppr EmptyLocalBinds = empty
138
139 instance OutputableBndr id => Outputable (HsValBinds id) where
140   ppr (ValBindsIn binds sigs)
141    = pprValBindsForUser binds sigs
142
143   ppr (ValBindsOut sccs sigs) 
144     = getPprStyle $ \ sty ->
145       if debugStyle sty then    -- Print with sccs showing
146         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
147      else
148         pprValBindsForUser (unionManyBags (map snd sccs)) sigs
149    where
150      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
151      pp_rec Recursive    = ptext SLIT("rec")
152      pp_rec NonRecursive = ptext SLIT("nonrec")
153
154 --  *not* pprLHsBinds because we don't want braces; 'let' and
155 -- 'where' include a list of HsBindGroups and we don't want
156 -- several groups of bindings each with braces around.
157 -- Sort by location before printing
158 pprValBindsForUser binds sigs
159   = vcat (map snd (sort_by_loc decls))
160   where
161
162     decls :: [(SrcSpan, SDoc)]
163     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
164             [(loc, ppr bind) | L loc bind <- bagToList binds]
165
166     sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
167
168 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
169 pprLHsBinds binds 
170   | isEmptyLHsBinds binds = empty
171   | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
172
173 ------------
174 emptyLocalBinds :: HsLocalBinds a
175 emptyLocalBinds = EmptyLocalBinds
176
177 isEmptyLocalBinds :: HsLocalBinds a -> Bool
178 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
179 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
180 isEmptyLocalBinds EmptyLocalBinds = True
181
182 isEmptyValBinds :: HsValBinds a -> Bool
183 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
184 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
185
186 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
187 emptyValBindsIn  = ValBindsIn emptyBag []
188 emptyValBindsOut = ValBindsOut []      []
189
190 emptyLHsBinds :: LHsBinds id
191 emptyLHsBinds = emptyBag
192
193 isEmptyLHsBinds :: LHsBinds id -> Bool
194 isEmptyLHsBinds = isEmptyBag
195
196 ------------
197 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
198 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
199   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
200 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
201   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
202 \end{code}
203
204 What AbsBinds means
205 ~~~~~~~~~~~~~~~~~~~
206          AbsBinds tvs
207                   [d1,d2]
208                   [(tvs1, f1p, f1m), 
209                    (tvs2, f2p, f2m)]
210                   BIND
211 means
212
213         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND 
214                                       in fm
215
216         gp = ...same again, with gm instead of fm
217
218 This is a pretty bad translation, because it duplicates all the bindings.
219 So the desugarer tries to do a better job:
220
221         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
222                                         (fm,gm) -> fm
223         ..ditto for gp..
224
225         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND 
226                                        in (fm,gm)
227
228 \begin{code}
229 instance OutputableBndr id => Outputable (HsBind id) where
230     ppr mbind = ppr_monobind mbind
231
232 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
233
234 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
235 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = ppr var <+> equals <+> pprExpr (unLoc rhs)
236 ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
237       -- ToDo: print infix if appropriate
238
239 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
240                          abs_exports = exports, abs_binds = val_binds })
241      = sep [ptext SLIT("AbsBinds"),
242             brackets (interpp'SP tyvars),
243             brackets (interpp'SP dictvars),
244             brackets (sep (punctuate comma (map ppr_exp exports)))]
245        $$
246        nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
247                         -- Print type signatures
248                 $$ pprLHsBinds val_binds )
249   where
250     ppr_exp (tvs, gbl, lcl, prags)
251         = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
252                 nest 2 (vcat (map (pprPrag gbl) prags))]
253 \end{code}
254
255 %************************************************************************
256 %*                                                                      *
257                 Implicit parameter bindings
258 %*                                                                      *
259 %************************************************************************
260
261 \begin{code}
262 data HsIPBinds id
263   = IPBinds 
264         [LIPBind id] 
265         (DictBinds id)  -- Only in typechecker output; binds 
266                         -- uses of the implicit parameters
267
268 isEmptyIPBinds :: HsIPBinds id -> Bool
269 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
270
271 type LIPBind id = Located (IPBind id)
272
273 -- | Implicit parameter bindings.
274 data IPBind id
275   = IPBind
276         (IPName id)
277         (LHsExpr id)
278
279 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
280   ppr (IPBinds bs ds) = vcat (map ppr bs) 
281                         $$ pprLHsBinds ds
282
283 instance (OutputableBndr id) => Outputable (IPBind id) where
284   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
285 \end{code}
286
287
288 %************************************************************************
289 %*                                                                      *
290 \subsection{Coercion functions}
291 %*                                                                      *
292 %************************************************************************
293
294 \begin{code}
295 -- A Coercion is an expression with a hole in it
296 -- We need coercions to have concrete form so that we can zonk them
297
298 data ExprCoFn
299   = CoHole                      -- The identity coercion
300   | CoCompose ExprCoFn ExprCoFn
301   | CoApps ExprCoFn [Id]                -- Non-empty list
302   | CoTyApps ExprCoFn [Type]            --   in all of these
303   | CoLams [Id] ExprCoFn                --   so that the identity coercion
304   | CoTyLams [TyVar] ExprCoFn           --   is just Hole
305   | CoLet (LHsBinds Id) ExprCoFn        -- Would be nicer to be core bindings
306
307 (<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
308 (<.>) = CoCompose
309
310 idCoercion :: ExprCoFn
311 idCoercion = CoHole
312
313 isIdCoercion :: ExprCoFn -> Bool
314 isIdCoercion CoHole = True
315 isIdCoercion other  = False
316 \end{code}
317
318
319 %************************************************************************
320 %*                                                                      *
321 \subsection{@Sig@: type signatures and value-modifying user pragmas}
322 %*                                                                      *
323 %************************************************************************
324
325 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
326 ``specialise this function to these four types...'') in with type
327 signatures.  Then all the machinery to move them into place, etc.,
328 serves for both.
329
330 \begin{code}
331 type LSig name = Located (Sig name)
332
333 data Sig name
334   = TypeSig     (Located name)  -- A bog-std type signature
335                 (LHsType name)
336
337   | SpecSig     (Located name)  -- Specialise a function or datatype ...
338                 (LHsType name)  -- ... to these types
339                 InlineSpec
340
341   | InlineSig   (Located name)  -- Function name
342                 InlineSpec
343
344   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the 
345                                 -- current instance decl
346
347   | FixSig      (FixitySig name)        -- Fixity declaration
348
349 type LFixitySig name = Located (FixitySig name)
350 data FixitySig name = FixitySig (Located name) Fixity 
351
352 -- A Prag conveys pragmas from the type checker to the desugarer
353 data Prag 
354   = InlinePrag 
355         InlineSpec
356
357   | SpecPrag   
358         (HsExpr Id)     -- An expression, of the given specialised type, which
359         PostTcType      -- specialises the polymorphic function
360         [Id]            -- Dicts mentioned free in the expression
361         InlineSpec      -- Inlining spec for the specialised function
362
363 isInlinePrag (InlinePrag _) = True
364 isInlinePrag prag           = False
365
366 isSpecPrag (SpecPrag _ _ _ _) = True
367 isSpecPrag prag               = False
368 \end{code}
369
370 \begin{code}
371 okBindSig :: NameSet -> LSig Name -> Bool
372 okBindSig ns sig = sigForThisGroup ns sig
373
374 okHsBootSig :: LSig Name -> Bool
375 okHsBootSig (L _ (TypeSig  _ _)) = True
376 okHsBootSig (L _ (FixSig _))     = True
377 okHsBootSig sig                  = False
378
379 okClsDclSig :: LSig Name -> Bool
380 okClsDclSig (L _ (SpecInstSig _)) = False
381 okClsDclSig sig                   = True        -- All others OK
382
383 okInstDclSig :: NameSet -> LSig Name -> Bool
384 okInstDclSig ns lsig@(L _ sig) = ok ns sig
385   where
386     ok ns (TypeSig _ _)   = False
387     ok ns (FixSig _)      = False
388     ok ns (SpecInstSig _) = True
389     ok ns sig             = sigForThisGroup ns lsig
390
391 sigForThisGroup :: NameSet -> LSig Name -> Bool
392 sigForThisGroup ns sig
393   = case sigName sig of
394         Nothing -> False
395         Just n  -> n `elemNameSet` ns
396
397 sigName :: LSig name -> Maybe name
398 sigName (L _ sig) = f sig
399  where
400     f (TypeSig   n _)          = Just (unLoc n)
401     f (SpecSig   n _ _)        = Just (unLoc n)
402     f (InlineSig n _)          = Just (unLoc n)
403     f (FixSig (FixitySig n _)) = Just (unLoc n)
404     f other                     = Nothing
405
406 isFixityLSig :: LSig name -> Bool
407 isFixityLSig (L _ (FixSig {})) = True
408 isFixityLSig _                 = False
409
410 isVanillaLSig :: LSig name -> Bool
411 isVanillaLSig (L _(TypeSig {})) = True
412 isVanillaLSig sig               = False
413
414 isSpecLSig :: LSig name -> Bool
415 isSpecLSig (L _(SpecSig {})) = True
416 isSpecLSig sig               = False
417
418 isSpecInstLSig (L _ (SpecInstSig {})) = True
419 isSpecInstLSig sig                    = False
420
421 isPragLSig :: LSig name -> Bool
422         -- Identifies pragmas 
423 isPragLSig (L _ (SpecSig {}))   = True
424 isPragLSig (L _ (InlineSig {})) = True
425 isPragLSig other                = False
426
427 isInlineLSig :: LSig name -> Bool
428         -- Identifies inline pragmas 
429 isInlineLSig (L _ (InlineSig {})) = True
430 isInlineLSig other                = False
431
432 hsSigDoc (TypeSig {})           = ptext SLIT("type signature")
433 hsSigDoc (SpecSig {})           = ptext SLIT("SPECIALISE pragma")
434 hsSigDoc (InlineSig _ spec)     = ppr spec <+> ptext SLIT("pragma")
435 hsSigDoc (SpecInstSig {})       = ptext SLIT("SPECIALISE instance pragma")
436 hsSigDoc (FixSig {})            = ptext SLIT("fixity declaration")
437 \end{code}
438
439 Signature equality is used when checking for duplicate signatures
440
441 \begin{code}
442 eqHsSig :: LSig Name -> LSig Name -> Bool
443 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
444 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
445 eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2))                 = s1 == s2 && unLoc n1 == unLoc n2
446         -- For specialisations, we don't have equality over
447         -- HsType, so it's not convenient to spot duplicate 
448         -- specialisations here.  Check for this later, when we're in Type land
449 eqHsSig _other1 _other2 = False
450 \end{code}
451
452 \begin{code}
453 instance (OutputableBndr name) => Outputable (Sig name) where
454     ppr sig = ppr_sig sig
455
456 ppr_sig :: OutputableBndr name => Sig name -> SDoc
457 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) ty
458 ppr_sig (FixSig fix_sig)          = ppr fix_sig
459 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var ty inl)
460 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
461 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
462
463 instance Outputable name => Outputable (FixitySig name) where
464   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
465
466 pragBrackets :: SDoc -> SDoc
467 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}") 
468
469 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
470 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
471
472 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
473 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
474
475 pprPrag :: Outputable id => id -> Prag -> SDoc
476 pprPrag var (InlinePrag inl)         = ppr inl <+> ppr var
477 pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl
478 \end{code}