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