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