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