Improve error reporting for "relevant bindings" again (Trac #8233)
[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 top_lvl 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 top_lvl 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 rec_tc prag_fn sig_fn bind_list 
413          InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list
414          CheckGen sig   -> tcPolyCheck 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   :: RecFlag       -- Whether it's recursive after breaking
435                    -- dependencies based on type signatures
436   -> PragFun -> TcSigFun
437   -> [LHsBind Name]
438   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
439
440 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
441   = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
442                                              (LetGblBndr prag_fn) 
443                                              bind_list
444        ; mono_ids' <- mapM tc_mono_info mono_infos
445        ; return (binds', mono_ids', NotTopLevel) }
446   where
447     tc_mono_info (name, _, mono_id)
448       = do { mono_ty' <- zonkTcType (idType mono_id)
449              -- Zonk, mainly to expose unboxed types to checkStrictBinds
450            ; let mono_id' = setIdType mono_id mono_ty'
451            ; _specs <- tcSpecPrags mono_id' (prag_fn name)
452            ; return mono_id' }
453            -- NB: tcPrags generates error messages for
454            --     specialisation pragmas for non-overloaded sigs
455            -- Indeed that is why we call it here!
456            -- So we can safely ignore _specs
457
458 ------------------
459 tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
460                              -- dependencies based on type signatures
461             -> PragFun -> TcSigInfo 
462             -> [LHsBind Name]
463             -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
464 -- There is just one binding, 
465 --   it binds a single variable,
466 --   it has a signature,
467 tcPolyCheck rec_tc prag_fn
468             sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
469                            , sig_theta = theta, sig_tau = tau, sig_loc = loc })
470             bind_list
471   = do { ev_vars <- newEvVars theta
472        ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
473              prag_sigs = prag_fn (idName poly_id)
474        ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped
475        ; (ev_binds, (binds', [mono_info])) 
476             <- setSrcSpan loc $  
477                checkConstraints skol_info tvs ev_vars $
478                tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
479                tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr bind_list
480
481        ; spec_prags <- tcSpecPrags poly_id prag_sigs
482        ; poly_id    <- addInlinePrags poly_id prag_sigs
483
484        ; let (_, _, mono_id) = mono_info
485              export = ABE { abe_wrap = idHsWrapper
486                           , abe_poly = poly_id
487                           , abe_mono = mono_id
488                           , abe_prags = SpecPrags spec_prags }
489              abs_bind = L loc $ AbsBinds 
490                         { abs_tvs = tvs
491                         , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
492                         , abs_exports = [export], abs_binds = binds' }
493              closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
494                     | otherwise                                     = NotTopLevel
495        ; return (unitBag abs_bind, [poly_id], closed) }
496
497 ------------------
498 tcPolyInfer 
499   :: RecFlag       -- Whether it's recursive after breaking
500                    -- dependencies based on type signatures
501   -> PragFun -> TcSigFun 
502   -> Bool         -- True <=> apply the monomorphism restriction
503   -> Bool         -- True <=> free vars have closed types
504   -> [LHsBind Name]
505   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
506 tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
507   = do { ((binds', mono_infos), wanted)
508              <- captureConstraints $
509                 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
510
511        ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
512        ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
513        ; (qtvs, givens, mr_bites, ev_binds) <- 
514                           simplifyInfer closed mono name_taus wanted
515
516        ; theta <- zonkTcThetaType (map evVarPred givens)
517        ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
518
519        ; loc <- getSrcSpanM
520        ; let poly_ids = map abe_poly exports
521              final_closed | closed && not mr_bites = TopLevel
522                           | otherwise              = NotTopLevel
523              abs_bind = L loc $ 
524                         AbsBinds { abs_tvs = qtvs
525                                  , abs_ev_vars = givens, abs_ev_binds = ev_binds
526                                  , abs_exports = exports, abs_binds = binds' }
527
528        ; traceTc "Binding:" (ppr final_closed $$
529                              ppr (poly_ids `zip` map idType poly_ids))
530        ; return (unitBag abs_bind, poly_ids, final_closed) }
531          -- poly_ids are guaranteed zonked by mkExport
532
533 --------------
534 mkExport :: PragFun 
535          -> [TyVar] -> TcThetaType      -- Both already zonked
536          -> MonoBindInfo
537          -> TcM (ABExport Id)
538 -- mkExport generates exports with 
539 --      zonked type variables, 
540 --      zonked poly_ids
541 -- The former is just because no further unifications will change
542 -- the quantified type variables, so we can fix their final form
543 -- right now.
544 -- The latter is needed because the poly_ids are used to extend the
545 -- type environment; see the invariant on TcEnv.tcExtendIdEnv 
546
547 -- Pre-condition: the qtvs and theta are already zonked
548
549 mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
550   = do  { mono_ty <- zonkTcType (idType mono_id)
551         ; let poly_id  = case mb_sig of
552                            Nothing  -> mkLocalId poly_name inferred_poly_ty
553                            Just sig -> sig_id sig
554                 -- poly_id has a zonked type
555
556               -- In the inference case (no signature) this stuff figures out
557               -- the right type variables and theta to quantify over
558               -- See Note [Impedence matching]
559               my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty))
560                             -- Include kind variables!  Trac #7916
561               my_tvs   = filter (`elemVarSet` my_tvs2) qtvs   -- Maintain original order
562               my_theta = filter (quantifyPred my_tvs2) theta
563               inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty
564
565         ; poly_id <- addInlinePrags poly_id prag_sigs
566         ; spec_prags <- tcSpecPrags poly_id prag_sigs
567                 -- tcPrags requires a zonked poly_id
568
569         ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
570         ; traceTc "mkExport: check sig" 
571                   (ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id)) 
572
573         -- Perform the impedence-matching and ambiguity check
574         -- right away.  If it fails, we want to fail now (and recover
575         -- in tcPolyBinds).  If we delay checking, we get an error cascade.
576         -- Remember we are in the tcPolyInfer case, so the type envt is 
577         -- closed (unless we are doing NoMonoLocalBinds in which case all bets
578         -- are off)
579         -- See Note [Impedence matching]
580         ; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
581                             captureConstraints $
582                             tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
583         ; ev_binds <- simplifyAmbiguityCheck poly_name wanted
584
585         ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
586                       , abe_poly = poly_id
587                       , abe_mono = mono_id
588                       , abe_prags = SpecPrags spec_prags }) }
589   where
590     inferred = isNothing mb_sig
591
592     mk_msg poly_id tidy_env
593       = return (tidy_env', msg)
594       where
595         msg | inferred  = hang (ptext (sLit "When checking that") <+> pp_name)
596                              2 (ptext (sLit "has the inferred type") <+> pp_ty)
597                           $$ ptext (sLit "Probable cause: the inferred type is ambiguous")
598             | otherwise = hang (ptext (sLit "When checking that") <+> pp_name)
599                              2 (ptext (sLit "has the specified type") <+> pp_ty)
600         pp_name = quotes (ppr poly_name)
601         pp_ty   = quotes (ppr tidy_ty)
602         (tidy_env', tidy_ty) = tidyOpenType tidy_env (idType poly_id)
603         
604
605     prag_sigs = prag_fn poly_name
606     origin    = AmbigOrigin sig_ctxt
607     sig_ctxt  = InfSigCtxt poly_name
608 \end{code}
609
610 Note [Impedence matching]
611 ~~~~~~~~~~~~~~~~~~~~~~~~~
612 Consider
613    f 0 x = x
614    f n x = g [] (not x)
615
616    g [] y = f 10 y
617    g _  y = f 9  y
618
619 After typechecking we'll get
620   f_mono_ty :: a -> Bool -> Bool   
621   g_mono_ty :: [b] -> Bool -> Bool 
622 with constraints
623   (Eq a, Num a)
624
625 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
626 The types we really want for f and g are
627    f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
628    g :: forall b. [b] -> Bool -> Bool
629
630 We can get these by "impedence matching":
631    tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
632    tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
633
634    f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
635    g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
636
637 Suppose the shared quantified tyvars are qtvs and constraints theta.
638 Then we want to check that 
639    f's polytype  is more polymorphic than   forall qtvs. theta => f_mono_ty
640 and the proof is the impedence matcher.  
641
642 Notice that the impedence matcher may do defaulting.  See Trac #7173.
643
644 It also cleverly does an ambiguity check; for example, rejecting
645    f :: F a -> a
646 where F is a non-injective type function.
647
648
649 \begin{code}
650 type PragFun = Name -> [LSig Name]
651
652 mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
653 mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
654   where
655     prs = mapCatMaybes get_sig sigs
656
657     get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
658     get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig  nm ty (add_arity nm inl))
659     get_sig (L l (InlineSig nm inl))  = Just (nm, L l $ InlineSig nm   (add_arity nm inl))
660     get_sig _                         = Nothing
661
662     add_arity (L _ n) inl_prag   -- Adjust inl_sat field to match visible arity of function
663       | Just ar <- lookupNameEnv ar_env n,
664         Inline <- inl_inline inl_prag     = inl_prag { inl_sat = Just ar }
665         -- add arity only for real INLINE pragmas, not INLINABLE
666       | otherwise                         = inl_prag
667
668     prag_env :: NameEnv [LSig Name]
669     prag_env = foldl add emptyNameEnv prs
670     add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
671
672     -- ar_env maps a local to the arity of its definition
673     ar_env :: NameEnv Arity
674     ar_env = foldrBag lhsBindArity emptyNameEnv binds
675
676 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
677 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
678   = extendNameEnv env (unLoc id) (matchGroupArity ms)
679 lhsBindArity _ env = env        -- PatBind/VarBind
680
681 ------------------
682 tcSpecPrags :: Id -> [LSig Name]
683             -> TcM [LTcSpecPrag]
684 -- Add INLINE and SPECIALSE pragmas
685 --    INLINE prags are added to the (polymorphic) Id directly
686 --    SPECIALISE prags are passed to the desugarer via TcSpecPrags
687 -- Pre-condition: the poly_id is zonked
688 -- Reason: required by tcSubExp
689 tcSpecPrags poly_id prag_sigs
690   = do { unless (null bad_sigs) warn_discarded_sigs
691        ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
692   where
693     spec_sigs = filter isSpecLSig prag_sigs
694     bad_sigs  = filter is_bad_sig prag_sigs
695     is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
696
697     warn_discarded_sigs = warnPrags poly_id bad_sigs $
698                           ptext (sLit "Discarding unexpected pragmas for")
699
700
701 --------------
702 tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
703 tcSpec poly_id prag@(SpecSig _ hs_ty inl) 
704   -- The Name in the SpecSig may not be the same as that of the poly_id
705   -- Example: SPECIALISE for a class method: the Name in the SpecSig is
706   --          for the selector Id, but the poly_id is something like $cop
707   = addErrCtxt (spec_ctxt prag) $
708     do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
709         ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
710                  (ptext (sLit "SPECIALISE pragma for non-overloaded function") 
711                   <+> quotes (ppr poly_id))
712                   -- Note [SPECIALISE pragmas]
713         ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
714         ; return (SpecPrag poly_id wrap inl) }
715   where
716     name      = idName poly_id
717     poly_ty   = idType poly_id
718     origin    = SpecPragOrigin name
719     sig_ctxt  = FunSigCtxt name
720     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
721
722 tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
723
724 --------------
725 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
726 -- SPECIALISE pragamas for imported things
727 tcImpPrags prags
728   = do { this_mod <- getModule
729        ; dflags <- getDynFlags
730        ; if (not_specialising dflags) then
731             return []
732          else
733             mapAndRecoverM (wrapLocM tcImpSpec) 
734             [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
735                                , not (nameIsLocalOrFrom this_mod name) ] }
736   where
737     -- Ignore SPECIALISE pragmas for imported things
738     -- when we aren't specialising, or when we aren't generating
739     -- code.  The latter happens when Haddocking the base library;
740     -- we don't wnat complaints about lack of INLINABLE pragmas 
741     not_specialising dflags
742       | not (gopt Opt_Specialise dflags) = True
743       | otherwise = case hscTarget dflags of
744                       HscNothing -> True
745                       HscInterpreted -> True
746                       _other         -> False
747
748 tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
749 tcImpSpec (name, prag)
750  = do { id <- tcLookupId name
751       ; unless (isAnyInlinePragma (idInlinePragma id))
752                (addWarnTc (impSpecErr name))
753       ; tcSpec id prag }
754
755 impSpecErr :: Name -> SDoc
756 impSpecErr name
757   = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
758        2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
759                , parens $ sep 
760                    [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
761                    , ptext (sLit "was compiled without -O")]])
762   where
763     mod = nameModule name
764
765 --------------
766 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
767 tcVectDecls decls 
768   = do { decls' <- mapM (wrapLocM tcVect) decls
769        ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
770              dups = findDupsEq (==) ids
771        ; mapM_ reportVectDups dups
772        ; traceTcConstraints "End of tcVectDecls"
773        ; return decls'
774        }
775   where
776     reportVectDups (first:_second:_more) 
777       = addErrAt (getSrcSpan first) $
778           ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
779     reportVectDups _ = return ()
780
781 --------------
782 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
783 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
784 --   type of the original definition as this requires internals of the vectoriser not available
785 --   during type checking.  Instead, constrain the rhs of a vectorisation declaration to be a single
786 --   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'
787 --   from the vectoriser here.
788 tcVect (HsVect name rhs)
789   = addErrCtxt (vectCtxt name) $
790     do { var <- wrapLocM tcLookupId name
791        ; let L rhs_loc (HsVar rhs_var_name) = rhs
792        ; rhs_id <- tcLookupId rhs_var_name
793        ; return $ HsVect var (L rhs_loc (HsVar rhs_id))
794        }
795
796 {- OLD CODE:
797          -- turn the vectorisation declaration into a single non-recursive binding
798        ; let bind    = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] 
799              sigFun  = const Nothing
800              pragFun = mkPragFun [] (unitBag bind)
801
802          -- perform type inference (including generalisation)
803        ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
804        
805        ; traceTc "tcVect inferred type" $ ppr (varType id')
806        ; traceTc "tcVect bindings"      $ ppr binds
807        
808          -- add all bindings, including the type variable and dictionary bindings produced by type
809          -- generalisation to the right-hand side of the vectorisation declaration
810        ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
811        ; let [bind']                                  = bagToList actualBinds
812              MatchGroup 
813                [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
814                _                                      = (fun_matches . unLoc) bind'
815              rhsWrapped                               = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
816         
817         -- We return the type-checked 'Id', to propagate the inferred signature
818         -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
819        ; return $ HsVect (L loc id') (Just rhsWrapped)
820        }
821  -}
822 tcVect (HsNoVect name)
823   = addErrCtxt (vectCtxt name) $
824     do { var <- wrapLocM tcLookupId name
825        ; return $ HsNoVect var
826        }
827 tcVect (HsVectTypeIn isScalar lname rhs_name)
828   = addErrCtxt (vectCtxt lname) $
829     do { tycon <- tcLookupLocatedTyCon lname
830        ; checkTc (   not isScalar             -- either    we have a non-SCALAR declaration
831                  || isJust rhs_name           -- or        we explicitly provide a vectorised type
832                  || tyConArity tycon == 0     -- otherwise the type constructor must be nullary
833                  )
834                  scalarTyConMustBeNullary
835
836        ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
837        ; return $ HsVectTypeOut isScalar tycon rhs_tycon
838        }
839 tcVect (HsVectTypeOut _ _ _)
840   = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
841 tcVect (HsVectClassIn lname)
842   = addErrCtxt (vectCtxt lname) $
843     do { cls <- tcLookupLocatedClass lname
844        ; return $ HsVectClassOut cls
845        }
846 tcVect (HsVectClassOut _)
847   = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
848 tcVect (HsVectInstIn linstTy)
849   = addErrCtxt (vectCtxt linstTy) $
850     do { (cls, tys) <- tcHsVectInst linstTy
851        ; inst       <- tcLookupInstance cls tys
852        ; return $ HsVectInstOut inst
853        }
854 tcVect (HsVectInstOut _)
855   = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
856
857 vectCtxt :: Outputable thing => thing -> SDoc
858 vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
859
860 scalarTyConMustBeNullary :: MsgDoc
861 scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
862
863 --------------
864 -- If typechecking the binds fails, then return with each
865 -- signature-less binder given type (forall a.a), to minimise 
866 -- subsequent error messages
867 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
868 recoveryCode binder_names sig_fn
869   = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
870         ; poly_ids <- mapM mk_dummy binder_names
871         ; return (emptyBag, poly_ids, if all is_closed poly_ids
872                                       then TopLevel else NotTopLevel) }
873   where
874     mk_dummy name 
875         | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
876         | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
877
878     is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))
879
880 forall_a_a :: TcType
881 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
882 \end{code}
883
884 Note [SPECIALISE pragmas]
885 ~~~~~~~~~~~~~~~~~~~~~~~~~
886 There is no point in a SPECIALISE pragma for a non-overloaded function:
887    reverse :: [a] -> [a]
888    {-# SPECIALISE reverse :: [Int] -> [Int] #-}
889
890 But SPECIALISE INLINE *can* make sense for GADTS:
891    data Arr e where
892      ArrInt :: !Int -> ByteArray# -> Arr Int
893      ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
894
895    (!:) :: Arr e -> Int -> e
896    {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}  
897    {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
898    (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
899    (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)
900
901 When (!:) is specialised it becomes non-recursive, and can usefully
902 be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
903 for a non-overloaded function.
904
905 %************************************************************************
906 %*                                                                      *
907 \subsection{tcMonoBind}
908 %*                                                                      *
909 %************************************************************************
910
911 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
912 The signatures have been dealt with already.
913
914 Note [Pattern bindings]
915 ~~~~~~~~~~~~~~~~~~~~~~~
916 The rule for typing pattern bindings is this:
917
918     ..sigs..
919     p = e
920
921 where 'p' binds v1..vn, and 'e' may mention v1..vn, 
922 typechecks exactly like
923
924     ..sigs..
925     x = e       -- Inferred type
926     v1 = case x of p -> v1
927     ..
928     vn = case x of p -> vn
929
930 Note that  
931     (f :: forall a. a -> a) = id
932 should not typecheck because
933        case id of { (f :: forall a. a->a) -> f }
934 will not typecheck.
935
936 \begin{code}
937 tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
938                         -- i.e. the binders are mentioned in their RHSs, and
939                         --      we are not rescued by a type signature
940             -> TcSigFun -> LetBndrSpec 
941             -> [LHsBind Name]
942             -> TcM (LHsBinds TcId, [MonoBindInfo])
943
944 tcMonoBinds is_rec sig_fn no_gen
945            [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
946                                 fun_matches = matches, bind_fvs = fvs })]
947                              -- Single function binding, 
948   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
949   , Nothing <- sig_fn name   -- ...with no type signature
950   =     -- In this very special case we infer the type of the
951         -- right hand side first (it may have a higher-rank type)
952         -- and *then* make the monomorphic Id for the LHS
953         -- e.g.         f = \(x::forall a. a->a) -> <body>
954         --      We want to infer a higher-rank type for f
955     setSrcSpan b_loc    $
956     do  { rhs_ty  <- newFlexiTyVarTy openTypeKind
957         ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
958         ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
959                                  -- We extend the error context even for a non-recursive 
960                                  -- function so that in type error messages we show the 
961                                  -- type of the thing whose rhs we are type checking
962                                tcMatchesFun name inf matches rhs_ty
963
964         ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
965                                               fun_matches = matches', bind_fvs = fvs,
966                                               fun_co_fn = co_fn, fun_tick = Nothing })),
967                   [(name, Nothing, mono_id)]) }
968
969 tcMonoBinds _ sig_fn no_gen binds
970   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
971
972         -- Bring the monomorphic Ids, into scope for the RHSs
973         ; let mono_info  = getMonoBindInfo tc_binds
974               rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
975                     -- A monomorphic binding for each term variable that lacks 
976                     -- a type sig.  (Ones with a sig are already in scope.)
977
978         ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) 
979                                        | (n,id) <- rhs_id_env]
980         ; binds' <- tcExtendIdEnv2 rhs_id_env $ 
981                     mapM (wrapLocM tcRhs) tc_binds
982         ; return (listToBag binds', mono_info) }
983
984 ------------------------
985 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
986 -- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
987 --      if there's a signature for it, use the instantiated signature type
988 --      otherwise invent a type variable
989 -- You see that quite directly in the FunBind case.
990 -- 
991 -- But there's a complication for pattern bindings:
992 --      data T = MkT (forall a. a->a)
993 --      MkT f = e
994 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
995 -- but we want to get (f::forall a. a->a) as the RHS environment.
996 -- The simplest way to do this is to typecheck the pattern, and then look up the
997 -- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
998 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
999
1000 data TcMonoBind         -- Half completed; LHS done, RHS not done
1001   = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name (LHsExpr Name)) 
1002   | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1003
1004 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
1005         -- Type signature (if any), and
1006         -- the monomorphic bound things
1007
1008 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1009 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
1010   | Just sig <- sig_fn name
1011   = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1012            , ppr name )  -- { f :: ty; f x = e } is always done via CheckGen
1013                          -- which gives rise to LetLclBndr.  It wouldn't make
1014                          -- sense to have a *polymorphic* function Id at this point
1015     do  { mono_name <- newLocalName name
1016         ; let mono_id = mkLocalId mono_name (sig_tau sig)
1017         ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
1018   | otherwise
1019   = do  { mono_ty <- newFlexiTyVarTy openTypeKind
1020         ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1021         ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
1022
1023 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1024   = do  { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1025                               mapM lookup_info (collectPatBinders pat)
1026
1027                 -- After typechecking the pattern, look up the binder
1028                 -- names, which the pattern has brought into scope.
1029               lookup_info :: Name -> TcM MonoBindInfo
1030               lookup_info name = do { mono_id <- tcLookupId name
1031                                     ; return (name, sig_fn name, mono_id) }
1032
1033         ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1034                                      tcInfer tc_pat
1035
1036         ; return (TcPatBind infos pat' grhss pat_ty) }
1037
1038 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1039         -- AbsBind, VarBind impossible
1040
1041 -------------------
1042 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1043 -- When we are doing pattern bindings, or multiple function bindings at a time
1044 -- we *don't* bring any scoped type variables into scope
1045 -- Wny not?  They are not completely rigid.
1046 -- That's why we have the special case for a single FunBind in tcMonoBinds
1047 tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
1048   = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1049             -- NotTopLevel: it's a monomorphic binding
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 (TcPatBind infos pat' grhss pat_ty)
1059   = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $
1060             -- NotTopLevel: it's a monomorphic binding
1061     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1062         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1063                     tcGRHSsPat grhss pat_ty
1064         ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
1065                           , bind_fvs = placeHolderNames
1066                           , pat_ticks = (Nothing,[]) }) }
1067
1068
1069 ---------------------
1070 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1071 getMonoBindInfo tc_binds
1072   = foldr (get_info . unLoc) [] tc_binds
1073   where
1074     get_info (TcFunBind info _ _ _)  rest = info : rest
1075     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1076 \end{code}
1077
1078
1079
1080 %************************************************************************
1081 %*                                                                      *
1082                 Signatures
1083 %*                                                                      *
1084 %************************************************************************
1085
1086 Type signatures are tricky.  See Note [Signature skolems] in TcType
1087
1088 @tcSigs@ checks the signatures for validity, and returns a list of
1089 {\em freshly-instantiated} signatures.  That is, the types are already
1090 split up, and have fresh type variables installed.  All non-type-signature
1091 "RenamedSigs" are ignored.
1092
1093 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1094 the variable's type, and after that checked to see whether they've
1095 been instantiated.
1096
1097 Note [Scoped tyvars]
1098 ~~~~~~~~~~~~~~~~~~~~
1099 The -XScopedTypeVariables flag brings lexically-scoped type variables
1100 into scope for any explicitly forall-quantified type variables:
1101         f :: forall a. a -> a
1102         f x = e
1103 Then 'a' is in scope inside 'e'.
1104
1105 However, we do *not* support this 
1106   - For pattern bindings e.g
1107         f :: forall a. a->a
1108         (f,g) = e
1109
1110 Note [More instantiated than scoped]
1111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1112 There may be more instantiated type variables than lexically-scoped 
1113 ones.  For example:
1114         type T a = forall b. b -> (a,b)
1115         f :: forall c. T c
1116 Here, the signature for f will have one scoped type variable, c,
1117 but two instantiated type variables, c' and b'.  
1118
1119 We assume that the scoped ones are at the *front* of sig_tvs,
1120 and remember the names from the original HsForAllTy in the TcSigFun.
1121
1122 Note [Signature skolems]
1123 ~~~~~~~~~~~~~~~~~~~~~~~~
1124 When instantiating a type signature, we do so with either skolems or
1125 SigTv meta-type variables depending on the use_skols boolean.  This
1126 variable is set True when we are typechecking a single function
1127 binding; and False for pattern bindings and a group of several
1128 function bindings.
1129
1130 Reason: in the latter cases, the "skolems" can be unified together, 
1131         so they aren't properly rigid in the type-refinement sense.
1132 NB: unless we are doing H98, each function with a sig will be done
1133     separately, even if it's mutually recursive, so use_skols will be True
1134
1135
1136 Note [Only scoped tyvars are in the TyVarEnv]
1137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1138 We are careful to keep only the *lexically scoped* type variables in
1139 the type environment.  Why?  After all, the renamer has ensured
1140 that only legal occurrences occur, so we could put all type variables
1141 into the type env.
1142
1143 But we want to check that two distinct lexically scoped type variables
1144 do not map to the same internal type variable.  So we need to know which
1145 the lexically-scoped ones are... and at the moment we do that by putting
1146 only the lexically scoped ones into the environment.
1147
1148 Note [Instantiate sig with fresh variables]
1149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1150 It's vital to instantiate a type signature with fresh variables.
1151 For example:
1152       type T = forall a. [a] -> [a]
1153       f :: T; 
1154       f = g where { g :: T; g = <rhs> }
1155
1156  We must not use the same 'a' from the defn of T at both places!!
1157 (Instantiation is only necessary because of type synonyms.  Otherwise,
1158 it's all cool; each signature has distinct type variables from the renamer.)
1159
1160 Note [Fail eagerly on bad signatures]
1161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1162 If a type signaure is wrong, fail immediately:
1163
1164  * the type sigs may bind type variables, so proceeding without them
1165    can lead to a cascade of errors
1166
1167  * the type signature might be ambiguous, in which case checking
1168    the code against the signature will give a very similar error
1169    to the ambiguity error.
1170
1171 ToDo: this means we fall over if any type sig
1172 is wrong (eg at the top level of the module), 
1173 which is over-conservative
1174
1175 \begin{code}
1176 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
1177 tcTySigs hs_sigs
1178   = checkNoErrs $   -- See Note [Fail eagerly on bad signatures]
1179     do { ty_sigs_s<- mapAndRecoverM tcTySig hs_sigs
1180        ; let ty_sigs = concat ty_sigs_s
1181              env = mkNameEnv [(idName (sig_id sig), sig) | sig <- ty_sigs]
1182        ; return (map sig_id ty_sigs, lookupNameEnv env) }
1183
1184 tcTySig :: LSig Name -> TcM [TcSigInfo]
1185 tcTySig (L loc (IdSig id))
1186   = do { sig <- instTcTySigFromId loc id
1187        ; return [sig] }
1188 tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty))
1189   = setSrcSpan loc $ 
1190     do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty
1191        ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) }
1192 tcTySig _ = return []
1193
1194 instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo
1195 instTcTySigFromId loc id
1196   = do { (tvs, theta, tau) <- tcInstType inst_sig_tyvars (idType id)
1197        ; return (TcSigInfo { sig_id = id, sig_loc = loc
1198                            , sig_tvs = [(Nothing, tv) | tv <- tvs]
1199                            , sig_theta = theta, sig_tau = tau }) }
1200   where
1201     -- Hack: in an instance decl we use the selector id as
1202     -- the template; but we do *not* want the SrcSpan on the Name of 
1203     -- those type variables to refer to the class decl, rather to
1204     -- the instance decl 
1205     inst_sig_tyvars tvs = tcInstSigTyVars (map set_loc tvs)
1206     set_loc tv = setTyVarName tv (mkInternalName (nameUnique n) (nameOccName n) loc)
1207       where
1208         n = tyVarName tv
1209
1210 instTcTySig :: LHsType Name -> TcType    -- HsType and corresponding TcType
1211             -> Name -> TcM TcSigInfo
1212 instTcTySig hs_ty@(L loc _) sigma_ty name
1213   = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1214        ; return (TcSigInfo { sig_id = poly_id, sig_loc = loc
1215                            , sig_tvs = zipEqual "instTcTySig" scoped_tvs inst_tvs
1216                            , sig_theta = theta, sig_tau = tau }) }
1217   where
1218     poly_id      = mkLocalId name sigma_ty
1219
1220     scoped_names = hsExplicitTvs hs_ty
1221     (sig_tvs,_)  = tcSplitForAllTys sigma_ty
1222
1223     scoped_tvs :: [Maybe Name]
1224     scoped_tvs = mk_scoped scoped_names sig_tvs
1225
1226     mk_scoped :: [Name] -> [TyVar] -> [Maybe Name]
1227     mk_scoped []     tvs      = [Nothing | _ <- tvs]
1228     mk_scoped (n:ns) (tv:tvs) 
1229            | n == tyVarName tv = Just n  : mk_scoped ns     tvs
1230            | otherwise         = Nothing : mk_scoped (n:ns) tvs
1231     mk_scoped (n:ns) [] = pprPanic "mk_scoped" (ppr name $$ ppr (n:ns) $$ ppr hs_ty $$ ppr sigma_ty)
1232
1233 -------------------------------
1234 data GeneralisationPlan 
1235   = NoGen               -- No generalisation, no AbsBinds
1236
1237   | InferGen            -- Implicit generalisation; there is an AbsBinds
1238        Bool             --   True <=> apply the MR; generalise only unconstrained type vars
1239        Bool             --   True <=> bindings mention only variables with closed types
1240                         --            See Note [Bindings with closed types] in TcRnTypes
1241
1242   | CheckGen TcSigInfo  -- One binding with a signature
1243                         -- Explicit generalisation; there is an AbsBinds
1244
1245 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1246 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1247
1248 instance Outputable GeneralisationPlan where
1249   ppr NoGen          = ptext (sLit "NoGen")
1250   ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
1251   ppr (CheckGen s)   = ptext (sLit "CheckGen") <+> ppr s
1252
1253 decideGeneralisationPlan 
1254    :: DynFlags -> TcTypeEnv -> [Name]
1255    -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1256 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1257   | bang_pat_binds                         = NoGen
1258   | Just sig <- one_funbind_with_sig binds = CheckGen sig
1259   | mono_local_binds                       = NoGen
1260   | otherwise                              = InferGen mono_restriction closed_flag
1261
1262   where
1263     bndr_set = mkNameSet bndr_names
1264     binds = map unLoc lbinds
1265
1266     bang_pat_binds = any isBangHsBind binds
1267        -- Bang patterns must not be polymorphic,
1268        -- because we are going to force them
1269        -- See Trac #4498
1270
1271     mono_restriction  = xopt Opt_MonomorphismRestriction dflags 
1272                      && any restricted binds
1273
1274     is_closed_ns :: NameSet -> Bool -> Bool
1275     is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1276         -- ns are the Names referred to from the RHS of this bind
1277
1278     is_closed_id :: Name -> Bool
1279     -- See Note [Bindings with closed types] in TcRnTypes
1280     is_closed_id name 
1281       | name `elemNameSet` bndr_set
1282       = True              -- Ignore binders in this groups, of course
1283       | Just thing <- lookupNameEnv type_env name
1284       = case thing of
1285           ATcId { tct_closed = cl } -> isTopLevel cl  -- This is the key line
1286           ATyVar {}                 -> False          -- In-scope type variables
1287           AGlobal {}                -> True           --    are not closed!
1288           _                         -> pprPanic "is_closed_id" (ppr name)
1289       | otherwise
1290       = WARN( isInternalName name, ppr name ) True
1291         -- The free-var set for a top level binding mentions
1292         -- imported things too, so that we can report unused imports
1293         -- These won't be in the local type env.  
1294         -- Ditto class method etc from the current module
1295     
1296     closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1297
1298     mono_local_binds = xopt Opt_MonoLocalBinds dflags 
1299                     && not closed_flag
1300
1301     no_sig n = isNothing (sig_fn n)
1302
1303     -- With OutsideIn, all nested bindings are monomorphic
1304     -- except a single function binding with a signature
1305     one_funbind_with_sig [FunBind { fun_id = v }] = sig_fn (unLoc v)
1306     one_funbind_with_sig _                        = Nothing
1307
1308     -- The Haskell 98 monomorphism resetriction
1309     restricted (PatBind {})                              = True
1310     restricted (VarBind { var_id = v })                  = no_sig v
1311     restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1312                                                            && no_sig (unLoc v)
1313     restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1314
1315     restricted_match (MG { mg_alts = L _ (Match [] _ _) : _ }) = True
1316     restricted_match _                                         = False
1317         -- No args => like a pattern binding
1318         -- Some args => a function binding
1319
1320 -------------------
1321 checkStrictBinds :: TopLevelFlag -> RecFlag
1322                  -> [LHsBind Name]
1323                  -> LHsBinds TcId -> [Id]
1324                  -> TcM ()
1325 -- Check that non-overloaded unlifted bindings are
1326 --      a) non-recursive,
1327 --      b) not top level, 
1328 --      c) not a multiple-binding group (more or less implied by (a))
1329
1330 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1331   | unlifted || bang_pat
1332   = do  { checkTc (isNotTopLevel top_lvl)
1333                   (strictBindErr "Top-level" unlifted orig_binds)
1334         ; checkTc (isNonRec rec_group)
1335                   (strictBindErr "Recursive" unlifted orig_binds)
1336
1337         ; checkTc (all is_monomorphic (bagToList tc_binds))
1338                   (polyBindErr orig_binds)
1339             -- data Ptr a = Ptr Addr#
1340             -- f x = let p@(Ptr y) = ... in ...
1341             -- Here the binding for 'p' is polymorphic, but does 
1342             -- not mix with an unlifted binding for 'y'.  You should
1343             -- use a bang pattern.  Trac #6078.
1344         
1345         ; checkTc (isSingleton orig_binds)
1346                   (strictBindErr "Multiple" unlifted orig_binds)
1347
1348         -- This should be a checkTc, not a warnTc, but as of GHC 6.11
1349         -- the versions of alex and happy available have non-conforming
1350         -- templates, so the GHC build fails if it's an error:
1351         ; warnUnlifted <- woptM Opt_WarnLazyUnliftedBindings
1352         ; warnTc (warnUnlifted && not bang_pat && lifted_pat)
1353                  -- No outer bang, but it's a compound pattern
1354                  -- E.g   (I# x#) = blah
1355                  -- Warn about this, but not about
1356                  --      x# = 4# +# 1#
1357                  --      (# a, b #) = ...
1358                  (unliftedMustBeBang orig_binds) }
1359   | otherwise
1360   = traceTc "csb2" (ppr poly_ids) >>
1361     return ()
1362   where
1363     unlifted    = any is_unlifted poly_ids
1364     bang_pat    = any (isBangHsBind    . unLoc) orig_binds
1365     lifted_pat  = any (isLiftedPatBind . unLoc) orig_binds
1366
1367     is_unlifted id = case tcSplitForAllTys (idType id) of
1368                        (_, rho) -> isUnLiftedType rho
1369
1370     is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1371                      = null tvs && null evs
1372     is_monomorphic _ = True
1373
1374 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1375 unliftedMustBeBang binds
1376   = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1377        2 (vcat (map ppr binds))
1378
1379 polyBindErr :: [LHsBind Name] -> SDoc
1380 polyBindErr binds
1381   = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
1382        2 (vcat [vcat (map ppr binds), 
1383                 ptext (sLit "Probable fix: use a bang pattern")])
1384
1385 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1386 strictBindErr flavour unlifted binds
1387   = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
1388        2 (vcat (map ppr binds))
1389   where
1390     msg | unlifted  = ptext (sLit "bindings for unlifted types")
1391         | otherwise = ptext (sLit "bang-pattern bindings")
1392 \end{code}
1393
1394
1395 %************************************************************************
1396 %*                                                                      *
1397 \subsection[TcBinds-errors]{Error contexts and messages}
1398 %*                                                                      *
1399 %************************************************************************
1400
1401
1402 \begin{code}
1403 -- This one is called on LHS, when pat and grhss are both Name 
1404 -- and on RHS, when pat is TcId and grhss is still Name
1405 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
1406 patMonoBindsCtxt pat grhss
1407   = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
1408 \end{code}