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