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