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