c45586be7cae04d85f9316c2868c72cd28dbdf18
[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@(L _ name) rhs_name)
695   = addErrCtxt (vectCtxt lname) $
696     do { tycon <- tcLookupTyCon name
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
705 vectCtxt :: Located Name -> SDoc
706 vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name
707
708 scalarTyConMustBeNullary :: Message
709 scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
710
711 --------------
712 -- If typechecking the binds fails, then return with each
713 -- signature-less binder given type (forall a.a), to minimise 
714 -- subsequent error messages
715 recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
716 recoveryCode binder_names sig_fn
717   = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
718         ; poly_ids <- mapM mk_dummy binder_names
719         ; return (emptyBag, poly_ids, if all is_closed poly_ids
720                                       then TopLevel else NotTopLevel) }
721   where
722     mk_dummy name 
723         | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
724         | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
725
726     is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))
727
728 forall_a_a :: TcType
729 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
730 \end{code}
731
732 Note [SPECIALISE pragmas]
733 ~~~~~~~~~~~~~~~~~~~~~~~~~
734 There is no point in a SPECIALISE pragma for a non-overloaded function:
735    reverse :: [a] -> [a]
736    {-# SPECIALISE reverse :: [Int] -> [Int] #-}
737
738 But SPECIALISE INLINE *can* make sense for GADTS:
739    data Arr e where
740      ArrInt :: !Int -> ByteArray# -> Arr Int
741      ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
742
743    (!:) :: Arr e -> Int -> e
744    {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}  
745    {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
746    (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
747    (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)
748
749 When (!:) is specialised it becomes non-recursive, and can usefully
750 be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
751 for a non-overloaded function.
752
753 %************************************************************************
754 %*                                                                      *
755 \subsection{tcMonoBind}
756 %*                                                                      *
757 %************************************************************************
758
759 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
760 The signatures have been dealt with already.
761
762 \begin{code}
763 tcMonoBinds :: TcSigFun -> LetBndrSpec 
764             -> RecFlag  -- Whether the binding is recursive for typechecking purposes
765                         -- i.e. the binders are mentioned in their RHSs, and
766                         --      we are not rescued by a type signature
767             -> [LHsBind Name]
768             -> TcM (LHsBinds TcId, [MonoBindInfo])
769
770 tcMonoBinds sig_fn no_gen is_rec
771            [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
772                                 fun_matches = matches, bind_fvs = fvs })]
773                              -- Single function binding, 
774   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
775   , Nothing <- sig_fn name   -- ...with no type signature
776   =     -- In this very special case we infer the type of the
777         -- right hand side first (it may have a higher-rank type)
778         -- and *then* make the monomorphic Id for the LHS
779         -- e.g.         f = \(x::forall a. a->a) -> <body>
780         --      We want to infer a higher-rank type for f
781     setSrcSpan b_loc    $
782     do  { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
783
784         ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
785         ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
786                                               fun_matches = matches', bind_fvs = fvs,
787                                               fun_co_fn = co_fn, fun_tick = Nothing })),
788                   [(name, Nothing, mono_id)]) }
789
790 tcMonoBinds sig_fn no_gen _ binds
791   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
792
793         -- Bring the monomorphic Ids, into scope for the RHSs
794         ; let mono_info  = getMonoBindInfo tc_binds
795               rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
796                     -- A monomorphic binding for each term variable that lacks 
797                     -- a type sig.  (Ones with a sig are already in scope.)
798
799         ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
800                     traceTc "tcMonoBinds" $  vcat [ ppr n <+> ppr id <+> ppr (idType id) 
801                                                   | (n,id) <- rhs_id_env]
802                     mapM (wrapLocM tcRhs) tc_binds
803         ; return (listToBag binds', mono_info) }
804
805 ------------------------
806 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
807 -- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
808 --      if there's a signature for it, use the instantiated signature type
809 --      otherwise invent a type variable
810 -- You see that quite directly in the FunBind case.
811 -- 
812 -- But there's a complication for pattern bindings:
813 --      data T = MkT (forall a. a->a)
814 --      MkT f = e
815 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
816 -- but we want to get (f::forall a. a->a) as the RHS environment.
817 -- The simplest way to do this is to typecheck the pattern, and then look up the
818 -- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
819 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
820
821 data TcMonoBind         -- Half completed; LHS done, RHS not done
822   = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name) 
823   | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
824
825 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
826         -- Type signature (if any), and
827         -- the monomorphic bound things
828
829 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
830 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
831   | Just sig <- sig_fn name
832   = do  { mono_id <- newSigLetBndr no_gen name sig
833         ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
834   | otherwise
835   = do  { mono_ty <- newFlexiTyVarTy argTypeKind
836         ; mono_id <- newNoSigLetBndr no_gen name mono_ty
837         ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
838
839 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
840   = do  { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
841                               mapM lookup_info (collectPatBinders pat)
842
843                 -- After typechecking the pattern, look up the binder
844                 -- names, which the pattern has brought into scope.
845               lookup_info :: Name -> TcM MonoBindInfo
846               lookup_info name = do { mono_id <- tcLookupId name
847                                     ; return (name, sig_fn name, mono_id) }
848
849         ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
850                                      tcInfer tc_pat
851
852         ; return (TcPatBind infos pat' grhss pat_ty) }
853
854 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
855         -- AbsBind, VarBind impossible
856
857 -------------------
858 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
859 -- When we are doing pattern bindings, or multiple function bindings at a time
860 -- we *don't* bring any scoped type variables into scope
861 -- Wny not?  They are not completely rigid.
862 -- That's why we have the special case for a single FunBind in tcMonoBinds
863 tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
864   = do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
865         ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
866                                             matches (idType mono_id)
867         ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
868                           , fun_matches = matches'
869                           , fun_co_fn = co_fn 
870                           , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
871
872 tcRhs (TcPatBind _ pat' grhss pat_ty)
873   = do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
874         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
875                     tcGRHSsPat grhss pat_ty
876         ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
877                           , bind_fvs = placeHolderNames }) }
878
879
880 ---------------------
881 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
882 getMonoBindInfo tc_binds
883   = foldr (get_info . unLoc) [] tc_binds
884   where
885     get_info (TcFunBind info _ _ _)  rest = info : rest
886     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
887 \end{code}
888
889
890 %************************************************************************
891 %*                                                                      *
892                 Generalisation
893 %*                                                                      *
894 %************************************************************************
895
896 unifyCtxts checks that all the signature contexts are the same
897 The type signatures on a mutually-recursive group of definitions
898 must all have the same context (or none).
899
900 The trick here is that all the signatures should have the same
901 context, and we want to share type variables for that context, so that
902 all the right hand sides agree a common vocabulary for their type
903 constraints
904
905 We unify them because, with polymorphic recursion, their types
906 might not otherwise be related.  This is a rather subtle issue.
907
908 \begin{code}
909 {-
910 unifyCtxts :: [TcSigInfo] -> TcM ()
911 -- Post-condition: the returned Insts are full zonked
912 unifyCtxts [] = return ()
913 unifyCtxts (sig1 : sigs)
914   = do  { traceTc "unifyCtxts" (ppr (sig1 : sigs))
915         ; mapM_ unify_ctxt sigs }
916   where
917     theta1 = sig_theta sig1
918     unify_ctxt :: TcSigInfo -> TcM ()
919     unify_ctxt sig@(TcSigInfo { sig_theta = theta })
920         = setSrcSpan (sig_loc sig)                      $
921           addErrCtxt (sigContextsCtxt sig1 sig)         $
922           do { mk_cos <- unifyTheta theta1 theta
923              ; -- Check whether all coercions are identity coercions
924                -- That can happen if we have, say
925                --         f :: C [a]   => ...
926                --         g :: C (F a) => ...
927                -- where F is a type function and (F a ~ [a])
928                -- Then unification might succeed with a coercion.  But it's much
929                -- much simpler to require that such signatures have identical contexts
930                checkTc (isReflMkCos mk_cos)
931                        (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
932              }
933
934 -----------------------------------------------
935 sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc
936 sigContextsCtxt sig1 sig2
937   = vcat [ptext (sLit "When matching the contexts of the signatures for"), 
938           nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
939                         ppr id2 <+> dcolon <+> ppr (idType id2)]),
940           ptext (sLit "The signature contexts in a mutually recursive group should all be identical")]
941   where
942     id1 = sig_id sig1
943     id2 = sig_id sig2
944 -}
945 \end{code}
946
947
948 @getTyVarsToGen@ decides what type variables to generalise over.
949
950 For a "restricted group" -- see the monomorphism restriction
951 for a definition -- we bind no dictionaries, and
952 remove from tyvars_to_gen any constrained type variables
953
954 *Don't* simplify dicts at this point, because we aren't going
955 to generalise over these dicts.  By the time we do simplify them
956 we may well know more.  For example (this actually came up)
957         f :: Array Int Int
958         f x = array ... xs where xs = [1,2,3,4,5]
959 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
960 stuff.  If we simplify only at the f-binding (not the xs-binding)
961 we'll know that the literals are all Ints, and we can just produce
962 Int literals!
963
964 Find all the type variables involved in overloading, the
965 "constrained_tyvars".  These are the ones we *aren't* going to
966 generalise.  We must be careful about doing this:
967
968  (a) If we fail to generalise a tyvar which is not actually
969         constrained, then it will never, ever get bound, and lands
970         up printed out in interface files!  Notorious example:
971                 instance Eq a => Eq (Foo a b) where ..
972         Here, b is not constrained, even though it looks as if it is.
973         Another, more common, example is when there's a Method inst in
974         the LIE, whose type might very well involve non-overloaded
975         type variables.
976   [NOTE: Jan 2001: I don't understand the problem here so I'm doing 
977         the simple thing instead]
978
979  (b) On the other hand, we mustn't generalise tyvars which are constrained,
980         because we are going to pass on out the unmodified LIE, with those
981         tyvars in it.  They won't be in scope if we've generalised them.
982
983 So we are careful, and do a complete simplification just to find the
984 constrained tyvars. We don't use any of the results, except to
985 find which tyvars are constrained.
986
987 Note [Polymorphic recursion]
988 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
989 The game plan for polymorphic recursion in the code above is 
990
991         * Bind any variable for which we have a type signature
992           to an Id with a polymorphic type.  Then when type-checking 
993           the RHSs we'll make a full polymorphic call.
994
995 This fine, but if you aren't a bit careful you end up with a horrendous
996 amount of partial application and (worse) a huge space leak. For example:
997
998         f :: Eq a => [a] -> [a]
999         f xs = ...f...
1000
1001 If we don't take care, after typechecking we get
1002
1003         f = /\a -> \d::Eq a -> let f' = f a d
1004                                in
1005                                \ys:[a] -> ...f'...
1006
1007 Notice the the stupid construction of (f a d), which is of course
1008 identical to the function we're executing.  In this case, the
1009 polymorphic recursion isn't being used (but that's a very common case).
1010 This can lead to a massive space leak, from the following top-level defn
1011 (post-typechecking)
1012
1013         ff :: [Int] -> [Int]
1014         ff = f Int dEqInt
1015
1016 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
1017 f' is another thunk which evaluates to the same thing... and you end
1018 up with a chain of identical values all hung onto by the CAF ff.
1019
1020         ff = f Int dEqInt
1021
1022            = let f' = f Int dEqInt in \ys. ...f'...
1023
1024            = let f' = let f' = f Int dEqInt in \ys. ...f'...
1025                       in \ys. ...f'...
1026
1027 Etc.
1028
1029 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
1030 which would make the space leak go away in this case
1031
1032 Solution: when typechecking the RHSs we always have in hand the
1033 *monomorphic* Ids for each binding.  So we just need to make sure that
1034 if (Method f a d) shows up in the constraints emerging from (...f...)
1035 we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
1036 to the "givens" when simplifying constraints.  That's what the "lies_avail"
1037 is doing.
1038
1039 Then we get
1040
1041         f = /\a -> \d::Eq a -> letrec
1042                                  fm = \ys:[a] -> ...fm...
1043                                in
1044                                fm
1045
1046 %************************************************************************
1047 %*                                                                      *
1048                 Signatures
1049 %*                                                                      *
1050 %************************************************************************
1051
1052 Type signatures are tricky.  See Note [Signature skolems] in TcType
1053
1054 @tcSigs@ checks the signatures for validity, and returns a list of
1055 {\em freshly-instantiated} signatures.  That is, the types are already
1056 split up, and have fresh type variables installed.  All non-type-signature
1057 "RenamedSigs" are ignored.
1058
1059 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1060 the variable's type, and after that checked to see whether they've
1061 been instantiated.
1062
1063 Note [Scoped tyvars]
1064 ~~~~~~~~~~~~~~~~~~~~
1065 The -XScopedTypeVariables flag brings lexically-scoped type variables
1066 into scope for any explicitly forall-quantified type variables:
1067         f :: forall a. a -> a
1068         f x = e
1069 Then 'a' is in scope inside 'e'.
1070
1071 However, we do *not* support this 
1072   - For pattern bindings e.g
1073         f :: forall a. a->a
1074         (f,g) = e
1075
1076   - For multiple function bindings, unless Opt_RelaxedPolyRec is on
1077         f :: forall a. a -> a
1078         f = g
1079         g :: forall b. b -> b
1080         g = ...f...
1081     Reason: we use mutable variables for 'a' and 'b', since they may
1082     unify to each other, and that means the scoped type variable would
1083     not stand for a completely rigid variable.
1084
1085     Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec
1086
1087
1088 Note [More instantiated than scoped]
1089 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1090 There may be more instantiated type variables than lexically-scoped 
1091 ones.  For example:
1092         type T a = forall b. b -> (a,b)
1093         f :: forall c. T c
1094 Here, the signature for f will have one scoped type variable, c,
1095 but two instantiated type variables, c' and b'.  
1096
1097 We assume that the scoped ones are at the *front* of sig_tvs,
1098 and remember the names from the original HsForAllTy in the TcSigFun.
1099
1100 Note [Signature skolems]
1101 ~~~~~~~~~~~~~~~~~~~~~~~~
1102 When instantiating a type signature, we do so with either skolems or
1103 SigTv meta-type variables depending on the use_skols boolean.  This
1104 variable is set True when we are typechecking a single function
1105 binding; and False for pattern bindings and a group of several
1106 function bindings.
1107
1108 Reason: in the latter cases, the "skolems" can be unified together, 
1109         so they aren't properly rigid in the type-refinement sense.
1110 NB: unless we are doing H98, each function with a sig will be done
1111     separately, even if it's mutually recursive, so use_skols will be True
1112
1113
1114 Note [Only scoped tyvars are in the TyVarEnv]
1115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1116 We are careful to keep only the *lexically scoped* type variables in
1117 the type environment.  Why?  After all, the renamer has ensured
1118 that only legal occurrences occur, so we could put all type variables
1119 into the type env.
1120
1121 But we want to check that two distinct lexically scoped type variables
1122 do not map to the same internal type variable.  So we need to know which
1123 the lexically-scoped ones are... and at the moment we do that by putting
1124 only the lexically scoped ones into the environment.
1125
1126 Note [Instantiate sig with fresh variables]
1127 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1128 It's vital to instantiate a type signature with fresh variables.
1129 For example:
1130       type T = forall a. [a] -> [a]
1131       f :: T; 
1132       f = g where { g :: T; g = <rhs> }
1133
1134  We must not use the same 'a' from the defn of T at both places!!
1135 (Instantiation is only necessary because of type synonyms.  Otherwise,
1136 it's all cool; each signature has distinct type variables from the renamer.)
1137
1138 \begin{code}
1139 type SigFun = Name -> Maybe ([Name], SrcSpan)
1140          -- Maps a let-binder to the list of
1141          -- type variables brought into scope
1142          -- by its type signature, plus location
1143          -- Nothing => no type signature
1144
1145 mkSigFun :: [LSig Name] -> SigFun
1146 -- Search for a particular type signature
1147 -- Precondition: the sigs are all type sigs
1148 -- Precondition: no duplicates
1149 mkSigFun sigs = lookupNameEnv env
1150   where
1151     env = mkNameEnv (concatMap mk_pair sigs)
1152     mk_pair (L loc (IdSig id))              = [(idName id, ([], loc))]
1153     mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames
1154       where
1155         f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc))
1156     mk_pair _                               = []
1157         -- The scoped names are the ones explicitly mentioned
1158         -- in the HsForAll.  (There may be more in sigma_ty, because
1159         -- of nested type synonyms.  See Note [More instantiated than scoped].)
1160         -- See Note [Only scoped tyvars are in the TyVarEnv]
1161 \end{code}
1162
1163 \begin{code}
1164 tcTySig :: LSig Name -> TcM [TcId]
1165 tcTySig (L span (TypeSig names ty))
1166   = setSrcSpan span $ mapM f names
1167   where
1168     f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
1169                        ; return (mkLocalId name sigma_ty) }
1170 tcTySig (L _ (IdSig id))
1171   = return [id]
1172 tcTySig s = pprPanic "tcTySig" (ppr s)
1173
1174 -------------------
1175 tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun
1176 tcInstSigs sig_fn bndrs
1177   = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs
1178        ; return (lookupNameEnv (mkNameEnv prs)) }
1179   where
1180     use_skols = isSingleton bndrs       -- See Note [Signature skolems]
1181
1182 tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo))
1183 -- For use_skols :: Bool see Note [Signature skolems]
1184 --
1185 -- We must instantiate with fresh uniques, 
1186 -- (see Note [Instantiate sig with fresh variables])
1187 -- although we keep the same print-name.
1188
1189 tcInstSig sig_fn use_skols name
1190   | Just (scoped_tvs, loc) <- sig_fn name
1191   = do  { poly_id <- tcLookupId name    -- Cannot fail; the poly ids are put into 
1192                                         -- scope when starting the binding group
1193         ; let poly_ty = idType poly_id
1194         ; (tvs, theta, tau) <- if use_skols
1195                                then tcInstType tcInstSkolTyVars poly_ty
1196                                else tcInstType tcInstSigTyVars  poly_ty
1197         ; let sig = TcSigInfo { sig_id = poly_id
1198                               , sig_scoped = scoped_tvs
1199                               , sig_tvs = tvs, sig_theta = theta, sig_tau = tau
1200                               , sig_loc = loc }
1201         ; return (Just (name, sig)) } 
1202   | otherwise
1203   = return Nothing
1204
1205 -------------------------------
1206 data GeneralisationPlan 
1207   = NoGen               -- No generalisation, no AbsBinds
1208
1209   | InferGen            -- Implicit generalisation; there is an AbsBinds
1210        Bool             --   True <=> apply the MR; generalise only unconstrained type vars
1211        Bool             --   True <=> bindings mention only variables with closed types
1212                         --            See Note [Bindings with closed types] in TcRnTypes
1213
1214   | CheckGen TcSigInfo  -- Explicit generalisation; there is an AbsBinds
1215
1216 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1217 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1218
1219 instance Outputable GeneralisationPlan where
1220   ppr NoGen          = ptext (sLit "NoGen")
1221   ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
1222   ppr (CheckGen s)   = ptext (sLit "CheckGen") <+> ppr s
1223
1224 decideGeneralisationPlan 
1225    :: DynFlags -> TcTypeEnv -> [Name]
1226    -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1227 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1228   | bang_pat_binds                         = NoGen
1229   | Just sig <- one_funbind_with_sig binds = CheckGen sig
1230   | mono_local_binds                       = NoGen
1231   | otherwise                              = InferGen mono_restriction closed_flag
1232
1233   where
1234     bndr_set = mkNameSet bndr_names
1235     binds = map unLoc lbinds
1236
1237     bang_pat_binds = any isBangHsBind binds
1238        -- Bang patterns must not be polymorphic,
1239        -- because we are going to force them
1240        -- See Trac #4498
1241
1242     mono_restriction  = xopt Opt_MonomorphismRestriction dflags 
1243                      && any restricted binds
1244
1245     is_closed_ns :: NameSet -> Bool -> Bool
1246     is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1247         -- ns are the Names referred to from the RHS of this bind
1248
1249     is_closed_id :: Name -> Bool
1250     -- See Note [Bindings with closed types] in TcRnTypes
1251     is_closed_id name 
1252       | name `elemNameSet` bndr_set
1253       = True              -- Ignore binders in this groups, of course
1254       | Just thing <- lookupNameEnv type_env name
1255       = case thing of
1256           ATcId { tct_closed = cl } -> isTopLevel cl  -- This is the key line
1257           ATyVar {}                 -> False          -- In-scope type variables
1258           AGlobal {}                -> True           --    are not closed!
1259           AThing {}                 -> pprPanic "is_closed_id" (ppr name)
1260       | otherwise
1261       = WARN( isInternalName name, ppr name ) True
1262         -- The free-var set for a top level binding mentions
1263         -- imported things too, so that we can report unused imports
1264         -- These won't be in the local type env.  
1265         -- Ditto class method etc from the current module
1266     
1267     closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1268
1269     mono_local_binds = xopt Opt_MonoLocalBinds dflags 
1270                     && not closed_flag
1271
1272     no_sig n = isNothing (sig_fn n)
1273
1274     -- With OutsideIn, all nested bindings are monomorphic
1275     -- except a single function binding with a signature
1276     one_funbind_with_sig [FunBind { fun_id = v }] = sig_fn (unLoc v)
1277     one_funbind_with_sig _                        = Nothing
1278
1279     -- The Haskell 98 monomorphism resetriction
1280     restricted (PatBind {})                              = True
1281     restricted (VarBind { var_id = v })                  = no_sig v
1282     restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1283                                                            && no_sig (unLoc v)
1284     restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1285
1286     restricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = True
1287     restricted_match _                                       = False
1288         -- No args => like a pattern binding
1289         -- Some args => a function binding
1290
1291 -------------------
1292 checkStrictBinds :: TopLevelFlag -> RecFlag
1293                  -> [LHsBind Name] -> [Id]
1294                  -> TcM ()
1295 -- Check that non-overloaded unlifted bindings are
1296 --      a) non-recursive,
1297 --      b) not top level, 
1298 --      c) not a multiple-binding group (more or less implied by (a))
1299
1300 checkStrictBinds top_lvl rec_group binds poly_ids
1301   | unlifted || bang_pat
1302   = do  { checkTc (isNotTopLevel top_lvl)
1303                   (strictBindErr "Top-level" unlifted binds)
1304         ; checkTc (isNonRec rec_group)
1305                   (strictBindErr "Recursive" unlifted binds)
1306         ; checkTc (isSingleton binds)
1307                   (strictBindErr "Multiple" unlifted binds)
1308         -- This should be a checkTc, not a warnTc, but as of GHC 6.11
1309         -- the versions of alex and happy available have non-conforming
1310         -- templates, so the GHC build fails if it's an error:
1311         ; warnUnlifted <- woptM Opt_WarnLazyUnliftedBindings
1312         ; warnTc (warnUnlifted && not bang_pat && lifted_pat)
1313                  -- No outer bang, but it's a compound pattern
1314                  -- E.g   (I# x#) = blah
1315                  -- Warn about this, but not about
1316                  --      x# = 4# +# 1#
1317                  --      (# a, b #) = ...
1318                  (unliftedMustBeBang binds) }
1319   | otherwise
1320   = return ()
1321   where
1322     unlifted    = any is_unlifted poly_ids
1323     bang_pat    = any (isBangHsBind . unLoc) binds
1324     lifted_pat  = any (isLiftedPatBind . unLoc) binds
1325     is_unlifted id = case tcSplitForAllTys (idType id) of
1326                        (_, rho) -> isUnLiftedType rho
1327
1328 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1329 unliftedMustBeBang binds
1330   = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1331        2 (pprBindList binds)
1332
1333 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1334 strictBindErr flavour unlifted binds
1335   = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
1336        2 (pprBindList binds)
1337   where
1338     msg | unlifted  = ptext (sLit "bindings for unlifted types")
1339         | otherwise = ptext (sLit "bang-pattern bindings")
1340
1341 pprBindList :: [LHsBind Name] -> SDoc
1342 pprBindList binds = vcat (map ppr binds)
1343 \end{code}
1344
1345
1346 %************************************************************************
1347 %*                                                                      *
1348 \subsection[TcBinds-errors]{Error contexts and messages}
1349 %*                                                                      *
1350 %************************************************************************
1351
1352
1353 \begin{code}
1354 -- This one is called on LHS, when pat and grhss are both Name 
1355 -- and on RHS, when pat is TcId and grhss is still Name
1356 patMonoBindsCtxt :: OutputableBndr id => LPat id -> GRHSs Name -> SDoc
1357 patMonoBindsCtxt pat grhss
1358   = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
1359 \end{code}