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