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