0f404c69237c6be5044820398fdb54df3b0288d5
[ghc.git] / compiler / typecheck / TcBinds.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[TcBinds]{TcBinds}
6
7 \begin{code}
8 module TcBinds ( tcLocalBinds, tcTopBinds, 
9                  tcHsBootSigs, tcPolyBinds,
10                  PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 
11                  TcSigInfo(..), SigFun, mkSigFun,
12                  badBootDeclErr ) where
13
14 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
15 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
16
17 import DynFlags
18 import HsSyn
19
20 import TcRnMonad
21 import TcEnv
22 import TcUnify
23 import TcSimplify
24 import TcHsType
25 import TcPat
26 import TcMType
27 import TcType
28 -- import Coercion
29 import TysPrim
30 import Id
31 import Var
32 import VarSet
33 import Name
34 import NameSet
35 import NameEnv
36 import SrcLoc
37 import Bag
38 import ListSetOps
39 import ErrUtils
40 import Digraph
41 import Maybes
42 import Util
43 import BasicTypes
44 import Outputable
45 import FastString
46
47 import Control.Monad
48
49 #include "HsVersions.h"
50 \end{code}
51
52
53 %************************************************************************
54 %*                                                                      *
55 \subsection{Type-checking bindings}
56 %*                                                                      *
57 %************************************************************************
58
59 @tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
60 it needs to know something about the {\em usage} of the things bound,
61 so that it can create specialisations of them.  So @tcBindsAndThen@
62 takes a function which, given an extended environment, E, typechecks
63 the scope of the bindings returning a typechecked thing and (most
64 important) an LIE.  It is this LIE which is then used as the basis for
65 specialising the things bound.
66
67 @tcBindsAndThen@ also takes a "combiner" which glues together the
68 bindings and the "thing" to make a new "thing".
69
70 The real work is done by @tcBindWithSigsAndThen@.
71
72 Recursive and non-recursive binds are handled in essentially the same
73 way: because of uniques there are no scoping issues left.  The only
74 difference is that non-recursive bindings can bind primitive values.
75
76 Even for non-recursive binding groups we add typings for each binder
77 to the LVE for the following reason.  When each individual binding is
78 checked the type of its LHS is unified with that of its RHS; and
79 type-checking the LHS of course requires that the binder is in scope.
80
81 At the top-level the LIE is sure to contain nothing but constant
82 dictionaries, which we resolve at the module level.
83
84 \begin{code}
85 tcTopBinds :: HsValBinds Name 
86            -> TcM ( LHsBinds TcId       -- Typechecked bindings
87                   , [LTcSpecPrag]       -- SPECIALISE prags for imported Ids
88                   , TcLclEnv)           -- Augmented environment
89
90         -- Note: returning the TcLclEnv is more than we really
91         --       want.  The bit we care about is the local bindings
92         --       and the free type variables thereof
93 tcTopBinds binds
94   = do  { (ValBindsOut prs sigs, env) <- tcValBinds TopLevel binds getLclEnv
95         ; let binds = foldr (unionBags . snd) emptyBag prs
96         ; specs <- tcImpPrags sigs
97         ; return (binds, specs, env) }
98         -- The top level bindings are flattened into a giant 
99         -- implicitly-mutually-recursive LHsBinds
100
101 tcHsBootSigs :: HsValBinds Name -> TcM [Id]
102 -- A hs-boot file has only one BindGroup, and it only has type
103 -- signatures in it.  The renamer checked all this
104 tcHsBootSigs (ValBindsOut binds sigs)
105   = do  { checkTc (null binds) badBootDeclErr
106         ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
107   where
108     tc_boot_sig (TypeSig lnames ty) = mapM f lnames
109       where
110         f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
111                            ; return (mkVanillaGlobal name sigma_ty) }
112         -- Notice that we make GlobalIds, not LocalIds
113     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
114 tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
115
116 badBootDeclErr :: Message
117 badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
118
119 ------------------------
120 tcLocalBinds :: HsLocalBinds Name -> TcM thing
121              -> TcM (HsLocalBinds TcId, thing)
122
123 tcLocalBinds EmptyLocalBinds thing_inside 
124   = do  { thing <- thing_inside
125         ; return (EmptyLocalBinds, thing) }
126
127 tcLocalBinds (HsValBinds binds) thing_inside
128   = do  { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside
129         ; return (HsValBinds binds', thing) }
130
131 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
132   = do  { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
133
134         -- If the binding binds ?x = E, we  must now 
135         -- discharge any ?x constraints in expr_lie
136         -- See Note [Implicit parameter untouchables]
137         ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
138                                   [] given_ips thing_inside
139
140         ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
141   where
142     ips = [ip | L _ (IPBind ip _) <- ip_binds]
143
144         -- I wonder if we should do these one at at time
145         -- Consider     ?x = 4
146         --              ?y = ?x + 1
147     tc_ip_bind (IPBind ip expr) 
148        = do { ty <- newFlexiTyVarTy argTypeKind
149             ; ip_id <- newIP ip ty
150             ; expr' <- tcMonoExpr expr ty
151             ; return (ip_id, (IPBind (IPName ip_id) expr')) }
152 \end{code}
153
154 Note [Implicit parameter untouchables]
155 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 We add the type variables in the types of the implicit parameters
157 as untouchables, not so much because we really must not unify them,
158 but rather because we otherwise end up with constraints like this
159     Num alpha, Implic { wanted = alpha ~ Int }
160 The constraint solver solves alpha~Int by unification, but then
161 doesn't float that solved constraint out (it's not an unsolved 
162 wanted).  Result disaster: the (Num alpha) is again solved, this
163 time by defaulting.  No no no.
164
165 However [Oct 10] this is all handled automatically by the 
166 untouchable-range idea.
167
168 \begin{code}
169 tcValBinds :: TopLevelFlag 
170            -> HsValBinds Name -> TcM thing
171            -> TcM (HsValBinds TcId, thing) 
172
173 tcValBinds _ (ValBindsIn binds _) _
174   = pprPanic "tcValBinds" (ppr binds)
175
176 tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
177   = do  {       -- Typecheck the signature
178         ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
179               ; ty_sigs = filter isTypeLSig sigs
180               ; sig_fn  = mkSigFun ty_sigs }
181
182         ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
183                 -- No recovery from bad signatures, because the type sigs
184                 -- may bind type variables, so proceeding without them
185                 -- can lead to a cascade of errors
186                 -- ToDo: this means we fall over immediately if any type sig
187                 -- is wrong, which is over-conservative, see Trac bug #745
188
189                 -- Extend the envt right away with all 
190                 -- the Ids declared with type signatures
191         ; (binds', thing) <- tcExtendIdEnv poly_ids $
192                              tcBindGroups top_lvl sig_fn prag_fn 
193                                           binds thing_inside
194
195         ; return (ValBindsOut binds' sigs, thing) }
196
197 ------------------------
198 tcBindGroups :: TopLevelFlag -> SigFun -> PragFun
199              -> [(RecFlag, LHsBinds Name)] -> TcM thing
200              -> TcM ([(RecFlag, LHsBinds TcId)], thing)
201 -- Typecheck a whole lot of value bindings,
202 -- one strongly-connected component at a time
203 -- Here a "strongly connected component" has the strightforward
204 -- meaning of a group of bindings that mention each other, 
205 -- ignoring type signatures (that part comes later)
206
207 tcBindGroups _ _ _ [] thing_inside
208   = do  { thing <- thing_inside
209         ; return ([], thing) }
210
211 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
212   = do  { (group', (groups', thing))
213                 <- tc_group top_lvl sig_fn prag_fn group $ 
214                    tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
215         ; return (group' ++ groups', thing) }
216
217 ------------------------
218 tc_group :: forall thing. 
219             TopLevelFlag -> SigFun -> PragFun
220          -> (RecFlag, LHsBinds Name) -> TcM thing
221          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
222
223 -- Typecheck one strongly-connected component of the original program.
224 -- We get a list of groups back, because there may 
225 -- be specialisations etc as well
226
227 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
228         -- A single non-recursive binding
229         -- We want to keep non-recursive things non-recursive
230         -- so that we desugar unlifted bindings correctly
231  =  do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn 
232                                               NonRecursive NonRecursive
233                                              (bagToList binds)
234        ; thing <- tcExtendLetEnv closed ids thing_inside
235        ; return ( [(NonRecursive, binds1)], thing) }
236
237 tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
238   =     -- To maximise polymorphism (assumes -XRelaxedPolyRec), we do a new 
239         -- strongly-connected-component analysis, this time omitting 
240         -- any references to variables with type signatures.
241     do  { traceTc "tc_group rec" (pprLHsBinds binds)
242         ; (binds1, _ids, thing) <- go sccs
243              -- Here is where we should do bindInstsOfLocalFuns
244              -- if we start having Methods again
245         ; return ([(Recursive, binds1)], thing) }
246                 -- Rec them all together
247   where
248     sccs :: [SCC (LHsBind Name)]
249     sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
250
251     go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
252     go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
253                         ; (binds2, ids2, thing)  <- tcExtendLetEnv closed ids1 $ go sccs
254                         ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
255     go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
256
257     tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
258     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
259
260     tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
261
262 ------------------------
263 mkEdges :: SigFun -> LHsBinds Name
264         -> [(LHsBind Name, BKey, [BKey])]
265
266 type BKey  = Int -- Just number off the bindings
267
268 mkEdges sig_fn binds
269   = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
270                          Just key <- [lookupNameEnv key_map n], no_sig n ])
271     | (bind, key) <- keyd_binds
272     ]
273   where
274     no_sig :: Name -> Bool
275     no_sig n = isNothing (sig_fn n)
276
277     keyd_binds = bagToList binds `zip` [0::BKey ..]
278
279     key_map :: NameEnv BKey     -- Which binding it comes from
280     key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
281                                      , bndr <- bindersOfHsBind bind ]
282
283 bindersOfHsBind :: HsBind Name -> [Name]
284 bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
285 bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
286 bindersOfHsBind (AbsBinds {})                = panic "bindersOfHsBind AbsBinds"
287 bindersOfHsBind (VarBind {})                 = panic "bindersOfHsBind VarBind"
288
289 ------------------------
290 tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun
291             -> RecFlag       -- Whether the group is really recursive
292             -> RecFlag       -- Whether it's recursive after breaking
293                              -- dependencies based on type signatures
294             -> [LHsBind Name]
295             -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
296
297 -- Typechecks a single bunch of bindings all together, 
298 -- and generalises them.  The bunch may be only part of a recursive
299 -- group, because we use type signatures to maximise polymorphism
300 --
301 -- Returns a list because the input may be a single non-recursive binding,
302 -- in which case the dependency order of the resulting bindings is
303 -- important.  
304 -- 
305 -- Knows nothing about the scope of the bindings
306
307 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
308   = setSrcSpan loc                              $
309     recoverM (recoveryCode binder_names sig_fn) $ do 
310         -- Set up main recover; take advantage of any type sigs
311
312     { traceTc "------------------------------------------------" empty
313     ; traceTc "Bindings for" (ppr binder_names)
314
315     -- Instantiate the polytypes of any binders that have signatures
316     -- (as determined by sig_fn), returning a TcSigInfo for each
317     ; tc_sig_fn <- tcInstSigs sig_fn binder_names
318
319     ; dflags   <- getDOpts
320     ; type_env <- getLclTypeEnv
321     ; let plan = decideGeneralisationPlan dflags type_env 
322                          binder_names bind_list tc_sig_fn
323     ; traceTc "Generalisation plan" (ppr plan)
324     ; result@(_, poly_ids, _) <- case plan of
325          NoGen          -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
326          InferGen mn cl -> tcPolyInfer mn cl tc_sig_fn prag_fn rec_tc bind_list
327          CheckGen sig   -> tcPolyCheck sig prag_fn rec_tc bind_list
328
329         -- Check whether strict bindings are ok
330         -- These must be non-recursive etc, and are not generalised
331         -- They desugar to a case expression in the end
332     ; checkStrictBinds top_lvl rec_group bind_list poly_ids
333
334     ; return result }
335   where
336     binder_names = collectHsBindListBinders bind_list
337     loc = foldr1 combineSrcSpans (map getLoc bind_list)
338          -- The mbinds have been dependency analysed and 
339          -- may no longer be adjacent; so find the narrowest
340          -- span that includes them all
341
342 ------------------
343 tcPolyNoGen 
344   :: TcSigFun -> PragFun
345   -> RecFlag       -- Whether it's recursive after breaking
346                    -- dependencies based on type signatures
347   -> [LHsBind Name]
348   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
349 -- No generalisation whatsoever
350
351 tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
352   = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) 
353                                              rec_tc bind_list
354        ; mono_ids' <- mapM tc_mono_info mono_infos
355        ; return (binds', mono_ids', NotTopLevel) }
356   where
357     tc_mono_info (name, _, mono_id)
358       = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
359              -- Zonk, mainly to expose unboxed types to checkStrictBinds
360            ; let mono_id' = setIdType mono_id mono_ty'
361            ; _specs <- tcSpecPrags mono_id' (prag_fn name)
362            ; return mono_id' }
363            -- NB: tcPrags generates error messages for
364            --     specialisation pragmas for non-overloaded sigs
365            -- Indeed that is why we call it here!
366            -- So we can safely ignore _specs
367
368 ------------------
369 tcPolyCheck :: TcSigInfo -> PragFun
370             -> RecFlag       -- Whether it's recursive after breaking
371                              -- dependencies based on type signatures
372             -> [LHsBind Name]
373             -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
374 -- There is just one binding, 
375 --   it binds a single variable,
376 --   it has a signature,
377 tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scoped
378                            , sig_theta = theta, sig_tau = tau })
379     prag_fn rec_tc bind_list
380   = do { loc <- getSrcSpanM
381        ; ev_vars <- newEvVars theta
382        ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
383              prag_sigs = prag_fn (idName poly_id)
384        ; (ev_binds, (binds', [mono_info])) 
385             <- checkConstraints skol_info tvs ev_vars $
386                tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs)    $
387                tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
388
389        ; spec_prags <- tcSpecPrags poly_id prag_sigs
390        ; poly_id    <- addInlinePrags poly_id prag_sigs
391
392        ; let (_, _, mono_id) = mono_info
393              export = ABE { abe_wrap = idHsWrapper
394                           , abe_poly = poly_id
395                           , abe_mono = mono_id
396                           , abe_prags = SpecPrags spec_prags }
397              abs_bind = L loc $ AbsBinds 
398                         { abs_tvs = tvs
399                         , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
400                         , abs_exports = [export], abs_binds = binds' }
401              closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
402                     | otherwise                                     = NotTopLevel
403        ; return (unitBag abs_bind, [poly_id], closed) }
404
405 ------------------
406 tcPolyInfer 
407   :: Bool         -- True <=> apply the monomorphism restriction
408   -> Bool         -- True <=> free vars have closed types
409   -> TcSigFun -> PragFun
410   -> RecFlag       -- Whether it's recursive after breaking
411                    -- dependencies based on type signatures
412   -> [LHsBind Name]
413   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
414 tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
415   = do { ((binds', mono_infos), wanted) 
416              <- captureConstraints $
417                 tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
418
419        ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
420        ; (qtvs, givens, mr_bites, ev_binds) <- simplifyInfer closed mono name_taus wanted
421
422        ; theta <- zonkTcThetaType (map evVarPred givens)
423        ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
424
425        ; loc <- getSrcSpanM
426        ; let poly_ids = map abe_poly exports
427              final_closed | closed && not mr_bites = TopLevel
428                           | otherwise              = NotTopLevel
429              abs_bind = L loc $ 
430                         AbsBinds { abs_tvs = qtvs
431                                  , abs_ev_vars = givens, abs_ev_binds = ev_binds
432                                  , abs_exports = exports, abs_binds = binds' }
433
434        ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
435        ; return (unitBag abs_bind, poly_ids, final_closed)   
436          -- poly_ids are guaranteed zonked by mkExport
437   }
438
439
440 --------------
441 mkExport :: PragFun 
442          -> [TyVar] -> TcThetaType      -- Both already zonked
443          -> MonoBindInfo
444          -> TcM (ABExport Id)
445 -- mkExport generates exports with 
446 --      zonked type variables, 
447 --      zonked poly_ids
448 -- The former is just because no further unifications will change
449 -- the quantified type variables, so we can fix their final form
450 -- right now.
451 -- The latter is needed because the poly_ids are used to extend the
452 -- type environment; see the invariant on TcEnv.tcExtendIdEnv 
453
454 -- Pre-condition: the qtvs and theta are already zonked
455
456 mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
457   = do  { mono_ty <- zonkTcTypeCarefully (idType mono_id)
458         ; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty
459               my_tvs   = filter (`elemVarSet` used_tvs) qtvs
460               used_tvs = tyVarsOfTheta theta `unionVarSet` tyVarsOfType mono_ty
461
462               poly_id  = case mb_sig of
463                            Nothing  -> mkLocalId poly_name inferred_poly_ty
464                            Just sig -> sig_id sig
465                 -- poly_id has a zonked type
466
467         ; poly_id <- addInlinePrags poly_id prag_sigs
468         ; spec_prags <- tcSpecPrags poly_id prag_sigs
469                 -- tcPrags requires a zonked poly_id
470
471         ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
472         ; traceTc "mkExport: check sig" 
473                   (ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id)) 
474
475         -- Perform the impedence-matching and ambiguity check
476         -- right away.  If it fails, we want to fail now (and recover
477         -- in tcPolyBinds).  If we delay checking, we get an error cascade.
478         -- Remember we are in the tcPolyInfer case, so the type envt is 
479         -- closed (unless we are doing NoMonoLocalBinds in which case all bets
480         -- are off)
481         ; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
482                             captureConstraints $
483                             tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
484         ; ev_binds <- simplifyAmbiguityCheck poly_name wanted
485
486         ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
487                       , abe_poly = poly_id
488                       , abe_mono = mono_id
489                       , abe_prags = SpecPrags spec_prags }) }
490   where
491     inferred = isNothing mb_sig
492
493     mk_msg poly_id tidy_env
494       = return (tidy_env', msg)
495       where
496         msg | inferred  = hang (ptext (sLit "When checking that") <+> pp_name)
497                              2 (ptext (sLit "has the inferred type") <+> pp_ty)
498                           $$ ptext (sLit "Probable cause: the inferred type is ambiguous")
499             | otherwise = hang (ptext (sLit "When checking that") <+> pp_name)
500                              2 (ptext (sLit "has the specified type") <+> pp_ty)
501         pp_name = quotes (ppr poly_name)
502         pp_ty   = quotes (ppr tidy_ty)
503         (tidy_env', tidy_ty) = tidyOpenType tidy_env (idType poly_id)
504         
505
506     prag_sigs = prag_fn poly_name
507     origin    = AmbigOrigin poly_name
508     sig_ctxt  = InfSigCtxt poly_name
509
510 ------------------------
511 type PragFun = Name -> [LSig Name]
512
513 mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
514 mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
515   where
516     prs = mapCatMaybes get_sig sigs
517
518     get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
519     get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig  nm ty (add_arity nm inl))
520     get_sig (L l (InlineSig nm inl))  = Just (nm, L l $ InlineSig nm   (add_arity nm inl))
521     get_sig _                         = Nothing
522
523     add_arity (L _ n) inl_prag   -- Adjust inl_sat field to match visible arity of function
524       | Just ar <- lookupNameEnv ar_env n,
525         Inline <- inl_inline inl_prag     = inl_prag { inl_sat = Just ar }
526         -- add arity only for real INLINE pragmas, not INLINABLE
527       | otherwise                         = inl_prag
528
529     prag_env :: NameEnv [LSig Name]
530     prag_env = foldl add emptyNameEnv prs
531     add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
532
533     -- ar_env maps a local to the arity of its definition
534     ar_env :: NameEnv Arity
535     ar_env = foldrBag lhsBindArity emptyNameEnv binds
536
537 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
538 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
539   = extendNameEnv env (unLoc id) (matchGroupArity ms)
540 lhsBindArity _ env = env        -- PatBind/VarBind
541
542 ------------------
543 tcSpecPrags :: Id -> [LSig Name]
544             -> TcM [LTcSpecPrag]
545 -- Add INLINE and SPECIALSE pragmas
546 --    INLINE prags are added to the (polymorphic) Id directly
547 --    SPECIALISE prags are passed to the desugarer via TcSpecPrags
548 -- Pre-condition: the poly_id is zonked
549 -- Reason: required by tcSubExp
550 tcSpecPrags poly_id prag_sigs
551   = do { unless (null bad_sigs) warn_discarded_sigs
552        ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
553   where
554     spec_sigs = filter isSpecLSig prag_sigs
555     bad_sigs  = filter is_bad_sig prag_sigs
556     is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
557
558     warn_discarded_sigs = warnPrags poly_id bad_sigs $
559                           ptext (sLit "Discarding unexpected pragmas for")
560
561
562 --------------
563 tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
564 tcSpec poly_id prag@(SpecSig _ hs_ty inl) 
565   -- The Name in the SpecSig may not be the same as that of the poly_id
566   -- Example: SPECIALISE for a class method: the Name in the SpecSig is
567   --          for the selector Id, but the poly_id is something like $cop
568   = addErrCtxt (spec_ctxt prag) $
569     do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
570         ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
571                  (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id))
572                   -- Note [SPECIALISE pragmas]
573         ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
574         ; return (SpecPrag poly_id wrap inl) }
575   where
576     name      = idName poly_id
577     poly_ty   = idType poly_id
578     origin    = SpecPragOrigin name
579     sig_ctxt  = FunSigCtxt name
580     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
581
582 tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
583
584 --------------
585 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
586 -- SPECIALISE pragamas for imported things
587 tcImpPrags prags
588   = do { this_mod <- getModule
589        ; dflags <- getDOpts
590        ; if (not_specialising dflags) then
591             return []
592          else
593             mapAndRecoverM (wrapLocM tcImpSpec) 
594             [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
595                                , not (nameIsLocalOrFrom this_mod name) ] }
596   where
597     -- Ignore SPECIALISE pragmas for imported things
598     -- when we aren't specialising, or when we aren't generating
599     -- code.  The latter happens when Haddocking the base library;
600     -- we don't wnat complaints about lack of INLINABLE pragmas 
601     not_specialising dflags
602       | not (dopt Opt_Specialise dflags) = True
603       | otherwise = case hscTarget dflags of
604                       HscNothing -> True
605                       HscInterpreted -> True
606                       _other         -> False
607
608 tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
609 tcImpSpec (name, prag)
610  = do { id <- tcLookupId name
611       ; unless (isAnyInlinePragma (idInlinePragma id))
612                (addWarnTc (impSpecErr name))
613       ; tcSpec id prag }
614
615 impSpecErr :: Name -> SDoc
616 impSpecErr name
617   = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
618        2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
619                , parens $ sep 
620                    [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
621                    , ptext (sLit "was compiled without -O")]])
622   where
623     mod = nameModule name
624
625 --------------
626 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
627 tcVectDecls decls 
628   = do { decls' <- mapM (wrapLocM tcVect) decls
629        ; let ids  = map lvectDeclName decls'
630              dups = findDupsEq (==) ids
631        ; mapM_ reportVectDups dups
632        ; traceTcConstraints "End of tcVectDecls"
633        ; return decls'
634        }
635   where
636     reportVectDups (first:_second:_more) 
637       = addErrAt (getSrcSpan first) $
638           ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
639     reportVectDups _ = return ()
640
641 --------------
642 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
643 -- We can't typecheck the expression of a vectorisation declaration against the vectorised type
644 -- of the original definition as this requires internals of the vectoriser not available during
645 -- type checking.  Instead, we infer the type of the expression and leave it to the vectoriser
646 -- to check the compatibility of the Core types.
647 tcVect (HsVect name Nothing)
648   = addErrCtxt (vectCtxt name) $
649     do { id <- wrapLocM tcLookupId name
650        ; return $ HsVect id Nothing
651        }
652 tcVect (HsVect name@(L loc _) (Just rhs))
653   = addErrCtxt (vectCtxt name) $
654     do { _id <- wrapLocM tcLookupId name     -- need to ensure that the name is already defined
655
656          -- turn the vectorisation declaration into a single non-recursive binding
657        ; let bind    = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] 
658              sigFun  = const Nothing
659              pragFun = mkPragFun [] (unitBag bind)
660
661          -- perform type inference (including generalisation)
662        ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
663
664        ; traceTc "tcVect inferred type" $ ppr (varType id')
665        ; traceTc "tcVect bindings"      $ ppr binds
666        
667          -- add all bindings, including the type variable and dictionary bindings produced by type
668          -- generalisation to the right-hand side of the vectorisation declaration
669        ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
670        ; let [bind']                                  = bagToList actualBinds
671              MatchGroup 
672                [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
673                _                                      = (fun_matches . unLoc) bind'
674              rhsWrapped                               = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
675         
676         -- We return the type-checked 'Id', to propagate the inferred signature
677         -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
678        ; return $ HsVect (L loc id') (Just rhsWrapped)
679        }
680 tcVect (HsNoVect name)
681   = addErrCtxt (vectCtxt name) $
682     do { id <- wrapLocM tcLookupId name
683        ; return $ HsNoVect id
684        }
685
686 vectCtxt :: Located Name -> SDoc
687 vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name
688
689 --------------
690 -- If typechecking the binds fails, then return with each
691 -- signature-less binder given type (forall a.a), to minimise 
692 -- subsequent error messages
693 recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
694 recoveryCode binder_names sig_fn
695   = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
696         ; poly_ids <- mapM mk_dummy binder_names
697         ; return (emptyBag, poly_ids, TopLevel) }
698   where
699     mk_dummy name 
700         | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
701         | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
702
703 forall_a_a :: TcType
704 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
705 \end{code}
706
707 Note [SPECIALISE pragmas]
708 ~~~~~~~~~~~~~~~~~~~~~~~~~
709 There is no point in a SPECIALISE pragma for a non-overloaded function:
710    reverse :: [a] -> [a]
711    {-# SPECIALISE reverse :: [Int] -> [Int] #-}
712
713 But SPECIALISE INLINE *can* make sense for GADTS:
714    data Arr e where
715      ArrInt :: !Int -> ByteArray# -> Arr Int
716      ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
717
718    (!:) :: Arr e -> Int -> e
719    {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}  
720    {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
721    (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
722    (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)
723
724 When (!:) is specialised it becomes non-recursive, and can usefully
725 be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
726 for a non-overloaded function.
727
728 %************************************************************************
729 %*                                                                      *
730 \subsection{tcMonoBind}
731 %*                                                                      *
732 %************************************************************************
733
734 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
735 The signatures have been dealt with already.
736
737 \begin{code}
738 tcMonoBinds :: TcSigFun -> LetBndrSpec 
739             -> RecFlag  -- Whether the binding is recursive for typechecking purposes
740                         -- i.e. the binders are mentioned in their RHSs, and
741                         --      we are not rescued by a type signature
742             -> [LHsBind Name]
743             -> TcM (LHsBinds TcId, [MonoBindInfo])
744
745 tcMonoBinds sig_fn no_gen is_rec
746            [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
747                                 fun_matches = matches, bind_fvs = fvs })]
748                              -- Single function binding, 
749   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
750   , Nothing <- sig_fn name   -- ...with no type signature
751   =     -- In this very special case we infer the type of the
752         -- right hand side first (it may have a higher-rank type)
753         -- and *then* make the monomorphic Id for the LHS
754         -- e.g.         f = \(x::forall a. a->a) -> <body>
755         --      We want to infer a higher-rank type for f
756     setSrcSpan b_loc    $
757     do  { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
758
759         ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
760         ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
761                                               fun_matches = matches', bind_fvs = fvs,
762                                               fun_co_fn = co_fn, fun_tick = Nothing })),
763                   [(name, Nothing, mono_id)]) }
764
765 tcMonoBinds sig_fn no_gen _ binds
766   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
767
768         -- Bring the monomorphic Ids, into scope for the RHSs
769         ; let mono_info  = getMonoBindInfo tc_binds
770               rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
771                     -- A monomorphic binding for each term variable that lacks 
772                     -- a type sig.  (Ones with a sig are already in scope.)
773
774         ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
775                     traceTc "tcMonoBinds" $  vcat [ ppr n <+> ppr id <+> ppr (idType id) 
776                                                   | (n,id) <- rhs_id_env]
777                     mapM (wrapLocM tcRhs) tc_binds
778         ; return (listToBag binds', mono_info) }
779
780 ------------------------
781 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
782 -- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
783 --      if there's a signature for it, use the instantiated signature type
784 --      otherwise invent a type variable
785 -- You see that quite directly in the FunBind case.
786 -- 
787 -- But there's a complication for pattern bindings:
788 --      data T = MkT (forall a. a->a)
789 --      MkT f = e
790 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
791 -- but we want to get (f::forall a. a->a) as the RHS environment.
792 -- The simplest way to do this is to typecheck the pattern, and then look up the
793 -- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
794 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
795
796 data TcMonoBind         -- Half completed; LHS done, RHS not done
797   = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name) 
798   | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
799
800 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
801         -- Type signature (if any), and
802         -- the monomorphic bound things
803
804 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
805 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
806   | Just sig <- sig_fn name
807   = do  { mono_id <- newSigLetBndr no_gen name sig
808         ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
809   | otherwise
810   = do  { mono_ty <- newFlexiTyVarTy argTypeKind
811         ; mono_id <- newNoSigLetBndr no_gen name mono_ty
812         ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
813
814 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
815   = do  { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
816                               mapM lookup_info (collectPatBinders pat)
817
818                 -- After typechecking the pattern, look up the binder
819                 -- names, which the pattern has brought into scope.
820               lookup_info :: Name -> TcM MonoBindInfo
821               lookup_info name = do { mono_id <- tcLookupId name
822                                     ; return (name, sig_fn name, mono_id) }
823
824         ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
825                                      tcInfer tc_pat
826
827         ; return (TcPatBind infos pat' grhss pat_ty) }
828
829 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
830         -- AbsBind, VarBind impossible
831
832 -------------------
833 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
834 -- When we are doing pattern bindings, or multiple function bindings at a time
835 -- we *don't* bring any scoped type variables into scope
836 -- Wny not?  They are not completely rigid.
837 -- That's why we have the special case for a single FunBind in tcMonoBinds
838 tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
839   = do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
840         ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
841                                             matches (idType mono_id)
842         ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
843                           , fun_matches = matches'
844                           , fun_co_fn = co_fn 
845                           , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
846
847 tcRhs (TcPatBind _ pat' grhss pat_ty)
848   = do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
849         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
850                     tcGRHSsPat grhss pat_ty
851         ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
852                           , bind_fvs = placeHolderNames }) }
853
854
855 ---------------------
856 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
857 getMonoBindInfo tc_binds
858   = foldr (get_info . unLoc) [] tc_binds
859   where
860     get_info (TcFunBind info _ _ _)  rest = info : rest
861     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
862 \end{code}
863
864
865 %************************************************************************
866 %*                                                                      *
867                 Generalisation
868 %*                                                                      *
869 %************************************************************************
870
871 unifyCtxts checks that all the signature contexts are the same
872 The type signatures on a mutually-recursive group of definitions
873 must all have the same context (or none).
874
875 The trick here is that all the signatures should have the same
876 context, and we want to share type variables for that context, so that
877 all the right hand sides agree a common vocabulary for their type
878 constraints
879
880 We unify them because, with polymorphic recursion, their types
881 might not otherwise be related.  This is a rather subtle issue.
882
883 \begin{code}
884 {-
885 unifyCtxts :: [TcSigInfo] -> TcM ()
886 -- Post-condition: the returned Insts are full zonked
887 unifyCtxts [] = return ()
888 unifyCtxts (sig1 : sigs)
889   = do  { traceTc "unifyCtxts" (ppr (sig1 : sigs))
890         ; mapM_ unify_ctxt sigs }
891   where
892     theta1 = sig_theta sig1
893     unify_ctxt :: TcSigInfo -> TcM ()
894     unify_ctxt sig@(TcSigInfo { sig_theta = theta })
895         = setSrcSpan (sig_loc sig)                      $
896           addErrCtxt (sigContextsCtxt sig1 sig)         $
897           do { cois <- unifyTheta theta1 theta
898              ; -- Check whether all coercions are identity coercions
899                -- That can happen if we have, say
900                --         f :: C [a]   => ...
901                --         g :: C (F a) => ...
902                -- where F is a type function and (F a ~ [a])
903                -- Then unification might succeed with a coercion.  But it's much
904                -- much simpler to require that such signatures have identical contexts
905                checkTc (all isReflCo cois)
906                        (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
907              }
908
909 -----------------------------------------------
910 sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc
911 sigContextsCtxt sig1 sig2
912   = vcat [ptext (sLit "When matching the contexts of the signatures for"), 
913           nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
914                         ppr id2 <+> dcolon <+> ppr (idType id2)]),
915           ptext (sLit "The signature contexts in a mutually recursive group should all be identical")]
916   where
917     id1 = sig_id sig1
918     id2 = sig_id sig2
919 -}
920 \end{code}
921
922
923 @getTyVarsToGen@ decides what type variables to generalise over.
924
925 For a "restricted group" -- see the monomorphism restriction
926 for a definition -- we bind no dictionaries, and
927 remove from tyvars_to_gen any constrained type variables
928
929 *Don't* simplify dicts at this point, because we aren't going
930 to generalise over these dicts.  By the time we do simplify them
931 we may well know more.  For example (this actually came up)
932         f :: Array Int Int
933         f x = array ... xs where xs = [1,2,3,4,5]
934 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
935 stuff.  If we simplify only at the f-binding (not the xs-binding)
936 we'll know that the literals are all Ints, and we can just produce
937 Int literals!
938
939 Find all the type variables involved in overloading, the
940 "constrained_tyvars".  These are the ones we *aren't* going to
941 generalise.  We must be careful about doing this:
942
943  (a) If we fail to generalise a tyvar which is not actually
944         constrained, then it will never, ever get bound, and lands
945         up printed out in interface files!  Notorious example:
946                 instance Eq a => Eq (Foo a b) where ..
947         Here, b is not constrained, even though it looks as if it is.
948         Another, more common, example is when there's a Method inst in
949         the LIE, whose type might very well involve non-overloaded
950         type variables.
951   [NOTE: Jan 2001: I don't understand the problem here so I'm doing 
952         the simple thing instead]
953
954  (b) On the other hand, we mustn't generalise tyvars which are constrained,
955         because we are going to pass on out the unmodified LIE, with those
956         tyvars in it.  They won't be in scope if we've generalised them.
957
958 So we are careful, and do a complete simplification just to find the
959 constrained tyvars. We don't use any of the results, except to
960 find which tyvars are constrained.
961
962 Note [Polymorphic recursion]
963 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
964 The game plan for polymorphic recursion in the code above is 
965
966         * Bind any variable for which we have a type signature
967           to an Id with a polymorphic type.  Then when type-checking 
968           the RHSs we'll make a full polymorphic call.
969
970 This fine, but if you aren't a bit careful you end up with a horrendous
971 amount of partial application and (worse) a huge space leak. For example:
972
973         f :: Eq a => [a] -> [a]
974         f xs = ...f...
975
976 If we don't take care, after typechecking we get
977
978         f = /\a -> \d::Eq a -> let f' = f a d
979                                in
980                                \ys:[a] -> ...f'...
981
982 Notice the the stupid construction of (f a d), which is of course
983 identical to the function we're executing.  In this case, the
984 polymorphic recursion isn't being used (but that's a very common case).
985 This can lead to a massive space leak, from the following top-level defn
986 (post-typechecking)
987
988         ff :: [Int] -> [Int]
989         ff = f Int dEqInt
990
991 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
992 f' is another thunk which evaluates to the same thing... and you end
993 up with a chain of identical values all hung onto by the CAF ff.
994
995         ff = f Int dEqInt
996
997            = let f' = f Int dEqInt in \ys. ...f'...
998
999            = let f' = let f' = f Int dEqInt in \ys. ...f'...
1000                       in \ys. ...f'...
1001
1002 Etc.
1003
1004 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
1005 which would make the space leak go away in this case
1006
1007 Solution: when typechecking the RHSs we always have in hand the
1008 *monomorphic* Ids for each binding.  So we just need to make sure that
1009 if (Method f a d) shows up in the constraints emerging from (...f...)
1010 we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
1011 to the "givens" when simplifying constraints.  That's what the "lies_avail"
1012 is doing.
1013
1014 Then we get
1015
1016         f = /\a -> \d::Eq a -> letrec
1017                                  fm = \ys:[a] -> ...fm...
1018                                in
1019                                fm
1020
1021 %************************************************************************
1022 %*                                                                      *
1023                 Signatures
1024 %*                                                                      *
1025 %************************************************************************
1026
1027 Type signatures are tricky.  See Note [Signature skolems] in TcType
1028
1029 @tcSigs@ checks the signatures for validity, and returns a list of
1030 {\em freshly-instantiated} signatures.  That is, the types are already
1031 split up, and have fresh type variables installed.  All non-type-signature
1032 "RenamedSigs" are ignored.
1033
1034 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1035 the variable's type, and after that checked to see whether they've
1036 been instantiated.
1037
1038 Note [Scoped tyvars]
1039 ~~~~~~~~~~~~~~~~~~~~
1040 The -XScopedTypeVariables flag brings lexically-scoped type variables
1041 into scope for any explicitly forall-quantified type variables:
1042         f :: forall a. a -> a
1043         f x = e
1044 Then 'a' is in scope inside 'e'.
1045
1046 However, we do *not* support this 
1047   - For pattern bindings e.g
1048         f :: forall a. a->a
1049         (f,g) = e
1050
1051   - For multiple function bindings, unless Opt_RelaxedPolyRec is on
1052         f :: forall a. a -> a
1053         f = g
1054         g :: forall b. b -> b
1055         g = ...f...
1056     Reason: we use mutable variables for 'a' and 'b', since they may
1057     unify to each other, and that means the scoped type variable would
1058     not stand for a completely rigid variable.
1059
1060     Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec
1061
1062
1063 Note [More instantiated than scoped]
1064 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1065 There may be more instantiated type variables than lexically-scoped 
1066 ones.  For example:
1067         type T a = forall b. b -> (a,b)
1068         f :: forall c. T c
1069 Here, the signature for f will have one scoped type variable, c,
1070 but two instantiated type variables, c' and b'.  
1071
1072 We assume that the scoped ones are at the *front* of sig_tvs,
1073 and remember the names from the original HsForAllTy in the TcSigFun.
1074
1075 Note [Signature skolems]
1076 ~~~~~~~~~~~~~~~~~~~~~~~~
1077 When instantiating a type signature, we do so with either skolems or
1078 SigTv meta-type variables depending on the use_skols boolean.  This
1079 variable is set True when we are typechecking a single function
1080 binding; and False for pattern bindings and a group of several
1081 function bindings.
1082
1083 Reason: in the latter cases, the "skolems" can be unified together, 
1084         so they aren't properly rigid in the type-refinement sense.
1085 NB: unless we are doing H98, each function with a sig will be done
1086     separately, even if it's mutually recursive, so use_skols will be True
1087
1088
1089 Note [Only scoped tyvars are in the TyVarEnv]
1090 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1091 We are careful to keep only the *lexically scoped* type variables in
1092 the type environment.  Why?  After all, the renamer has ensured
1093 that only legal occurrences occur, so we could put all type variables
1094 into the type env.
1095
1096 But we want to check that two distinct lexically scoped type variables
1097 do not map to the same internal type variable.  So we need to know which
1098 the lexically-scoped ones are... and at the moment we do that by putting
1099 only the lexically scoped ones into the environment.
1100
1101 Note [Instantiate sig with fresh variables]
1102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1103 It's vital to instantiate a type signature with fresh variables.
1104 For example:
1105       type T = forall a. [a] -> [a]
1106       f :: T; 
1107       f = g where { g :: T; g = <rhs> }
1108
1109  We must not use the same 'a' from the defn of T at both places!!
1110 (Instantiation is only necessary because of type synonyms.  Otherwise,
1111 it's all cool; each signature has distinct type variables from the renamer.)
1112
1113 \begin{code}
1114 type SigFun = Name -> Maybe ([Name], SrcSpan)
1115          -- Maps a let-binder to the list of
1116          -- type variables brought into scope
1117          -- by its type signature, plus location
1118          -- Nothing => no type signature
1119
1120 mkSigFun :: [LSig Name] -> SigFun
1121 -- Search for a particular type signature
1122 -- Precondition: the sigs are all type sigs
1123 -- Precondition: no duplicates
1124 mkSigFun sigs = lookupNameEnv env
1125   where
1126     env = mkNameEnv (concatMap mk_pair sigs)
1127     mk_pair (L loc (IdSig id))              = [(idName id, ([], loc))]
1128     mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames
1129       where
1130         f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc))
1131     mk_pair _                               = []
1132         -- The scoped names are the ones explicitly mentioned
1133         -- in the HsForAll.  (There may be more in sigma_ty, because
1134         -- of nested type synonyms.  See Note [More instantiated than scoped].)
1135         -- See Note [Only scoped tyvars are in the TyVarEnv]
1136 \end{code}
1137
1138 \begin{code}
1139 tcTySig :: LSig Name -> TcM [TcId]
1140 tcTySig (L span (TypeSig names ty))
1141   = setSrcSpan span $ mapM f names
1142   where
1143     f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
1144                        ; return (mkLocalId name sigma_ty) }
1145 tcTySig (L _ (IdSig id))
1146   = return [id]
1147 tcTySig s = pprPanic "tcTySig" (ppr s)
1148
1149 -------------------
1150 tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun
1151 tcInstSigs sig_fn bndrs
1152   = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs
1153        ; return (lookupNameEnv (mkNameEnv prs)) }
1154   where
1155     use_skols = isSingleton bndrs       -- See Note [Signature skolems]
1156
1157 tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo))
1158 -- For use_skols :: Bool see Note [Signature skolems]
1159 --
1160 -- We must instantiate with fresh uniques, 
1161 -- (see Note [Instantiate sig with fresh variables])
1162 -- although we keep the same print-name.
1163
1164 tcInstSig sig_fn use_skols name
1165   | Just (scoped_tvs, loc) <- sig_fn name
1166   = do  { poly_id <- tcLookupId name    -- Cannot fail; the poly ids are put into 
1167                                         -- scope when starting the binding group
1168         ; let poly_ty = idType poly_id
1169         ; (tvs, theta, tau) <- if use_skols
1170                                then tcInstType tcInstSkolTyVars poly_ty
1171                                else tcInstType tcInstSigTyVars  poly_ty
1172         ; let sig = TcSigInfo { sig_id = poly_id
1173                               , sig_scoped = scoped_tvs
1174                               , sig_tvs = tvs, sig_theta = theta, sig_tau = tau
1175                               , sig_loc = loc }
1176         ; return (Just (name, sig)) } 
1177   | otherwise
1178   = return Nothing
1179
1180 -------------------------------
1181 data GeneralisationPlan 
1182   = NoGen               -- No generalisation, no AbsBinds
1183   | InferGen            -- Implicit generalisation; there is an AbsBinds
1184        Bool             --   True <=> apply the MR; generalise only unconstrained type vars
1185        Bool             --   True <=> bindings mention only variables with closed types
1186   | CheckGen TcSigInfo  -- Explicit generalisation; there is an AbsBinds
1187
1188 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1189 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1190
1191 instance Outputable GeneralisationPlan where
1192   ppr NoGen          = ptext (sLit "NoGen")
1193   ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
1194   ppr (CheckGen s)   = ptext (sLit "CheckGen") <+> ppr s
1195
1196 decideGeneralisationPlan 
1197    :: DynFlags -> TcTypeEnv -> [Name]
1198    -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1199 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1200   | bang_pat_binds                         = NoGen
1201   | Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
1202                                              then NoGen       -- Optimise common case
1203                                              else CheckGen sig
1204   | mono_local_binds                       = NoGen
1205   | otherwise                              = InferGen mono_restriction closed_flag
1206
1207   where
1208     bndr_set = mkNameSet bndr_names
1209     binds = map unLoc lbinds
1210
1211     bang_pat_binds = any isBangHsBind binds
1212        -- Bang patterns must not be polymorphic,
1213        -- because we are going to force them
1214        -- See Trac #4498
1215
1216     mono_restriction  = xopt Opt_MonomorphismRestriction dflags 
1217                      && any restricted binds
1218
1219     is_closed_ns :: NameSet -> Bool -> Bool
1220     is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1221         -- ns are the Names referred to from the RHS of this bind
1222
1223     is_closed_id :: Name -> Bool
1224     is_closed_id name 
1225       | name `elemNameSet` bndr_set
1226       = True              -- Ignore binders in this groups, of course
1227       | Just (ATcId { tct_closed = cl }) <- lookupNameEnv type_env name
1228       = isTopLevel cl     -- This is the key line
1229       | otherwise
1230       = WARN( isInternalName name, ppr name ) True
1231         -- The free-var set for a top level binding mentions
1232         -- imported things too, so that we can report unused imports
1233         -- These won't be in the local type env.  
1234         -- Ditto class method etc from the current module
1235     
1236     closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1237
1238     mono_local_binds = xopt Opt_MonoLocalBinds dflags 
1239                     && not closed_flag
1240
1241     no_sig n = isNothing (sig_fn n)
1242
1243     -- With OutsideIn, all nested bindings are monomorphic
1244     -- except a single function binding with a signature
1245     one_funbind_with_sig [FunBind { fun_id = v }] = sig_fn (unLoc v)
1246     one_funbind_with_sig _                        = Nothing
1247
1248     -- The Haskell 98 monomorphism resetriction
1249     restricted (PatBind {})                              = True
1250     restricted (VarBind { var_id = v })                  = no_sig v
1251     restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1252                                                            && no_sig (unLoc v)
1253     restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1254
1255     restricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = True
1256     restricted_match _                                       = False
1257         -- No args => like a pattern binding
1258         -- Some args => a function binding
1259
1260 -------------------
1261 checkStrictBinds :: TopLevelFlag -> RecFlag
1262                  -> [LHsBind Name] -> [Id]
1263                  -> TcM ()
1264 -- Check that non-overloaded unlifted bindings are
1265 --      a) non-recursive,
1266 --      b) not top level, 
1267 --      c) not a multiple-binding group (more or less implied by (a))
1268
1269 checkStrictBinds top_lvl rec_group binds poly_ids
1270   | unlifted || bang_pat
1271   = do  { checkTc (isNotTopLevel top_lvl)
1272                   (strictBindErr "Top-level" unlifted binds)
1273         ; checkTc (isNonRec rec_group)
1274                   (strictBindErr "Recursive" unlifted binds)
1275         ; checkTc (isSingleton binds)
1276                   (strictBindErr "Multiple" unlifted binds)
1277         -- This should be a checkTc, not a warnTc, but as of GHC 6.11
1278         -- the versions of alex and happy available have non-conforming
1279         -- templates, so the GHC build fails if it's an error:
1280         ; warnUnlifted <- woptM Opt_WarnLazyUnliftedBindings
1281         ; warnTc (warnUnlifted && not bang_pat && lifted_pat)
1282                  -- No outer bang, but it's a compound pattern
1283                  -- E.g   (I# x#) = blah
1284                  -- Warn about this, but not about
1285                  --      x# = 4# +# 1#
1286                  --      (# a, b #) = ...
1287                  (unliftedMustBeBang binds) }
1288   | otherwise
1289   = return ()
1290   where
1291     unlifted    = any is_unlifted poly_ids
1292     bang_pat    = any (isBangHsBind . unLoc) binds
1293     lifted_pat  = any (isLiftedPatBind . unLoc) binds
1294     is_unlifted id = case tcSplitForAllTys (idType id) of
1295                        (_, rho) -> isUnLiftedType rho
1296
1297 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1298 unliftedMustBeBang binds
1299   = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1300        2 (pprBindList binds)
1301
1302 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1303 strictBindErr flavour unlifted binds
1304   = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
1305        2 (pprBindList binds)
1306   where
1307     msg | unlifted  = ptext (sLit "bindings for unlifted types")
1308         | otherwise = ptext (sLit "bang-pattern bindings")
1309
1310 pprBindList :: [LHsBind Name] -> SDoc
1311 pprBindList binds = vcat (map ppr binds)
1312 \end{code}
1313
1314
1315 %************************************************************************
1316 %*                                                                      *
1317 \subsection[TcBinds-errors]{Error contexts and messages}
1318 %*                                                                      *
1319 %************************************************************************
1320
1321
1322 \begin{code}
1323 -- This one is called on LHS, when pat and grhss are both Name 
1324 -- and on RHS, when pat is TcId and grhss is still Name
1325 patMonoBindsCtxt :: OutputableBndr id => LPat id -> GRHSs Name -> SDoc
1326 patMonoBindsCtxt pat grhss
1327   = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
1328 \end{code}