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