Re-add missing kind generalisation
[ghc.git] / compiler / typecheck / TcBinds.hs
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
8 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
9
10 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
11 tcValBinds, tcHsBootSigs, tcPolyCheck,
12 tcSpecPrags, tcSpecWrapper,
13 tcVectDecls, addTypecheckedBinds,
14 TcSigInfo(..), TcSigFun,
15 TcPragEnv, mkPragEnv,
16 tcUserTypeSig, instTcTySig, chooseInferredQuantifiers,
17 instTcTySigFromId, tcExtendTyVarEnvFromSig,
18 badBootDeclErr ) where
19
20 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
21 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
22 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
23 , tcPatSynBuilderBind, tcPatSynSig )
24 import DynFlags
25 import HsSyn
26 import HscTypes( isHsBootOrSig )
27 import TcRnMonad
28 import TcEnv
29 import TcUnify
30 import TcSimplify
31 import TcEvidence
32 import TcHsType
33 import TcPat
34 import TcMType
35 import Inst( topInstantiate, deeplyInstantiate )
36 import FamInstEnv( normaliseType )
37 import FamInst( tcGetFamInstEnvs )
38 import TyCon
39 import TcType
40 import TysPrim
41 import Id
42 import Var
43 import VarSet
44 import VarEnv( TidyEnv )
45 import Module
46 import Name
47 import NameSet
48 import NameEnv
49 import SrcLoc
50 import Bag
51 import ListSetOps
52 import ErrUtils
53 import Digraph
54 import Maybes
55 import Util
56 import BasicTypes
57 import Outputable
58 import Type(mkStrLitTy, tidyOpenType)
59 import PrelNames( mkUnboundName, gHC_PRIM, ipClassName )
60 import TcValidity (checkValidType)
61 import qualified GHC.LanguageExtensions as LangExt
62
63 import Control.Monad
64
65 #include "HsVersions.h"
66
67 {- *********************************************************************
68 * *
69 A useful helper function
70 * *
71 ********************************************************************* -}
72
73 addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv
74 addTypecheckedBinds tcg_env binds
75 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
76 -- Do not add the code for record-selector bindings
77 -- when compiling hs-boot files
78 | otherwise = tcg_env { tcg_binds = foldr unionBags
79 (tcg_binds tcg_env)
80 binds }
81
82 {-
83 ************************************************************************
84 * *
85 \subsection{Type-checking bindings}
86 * *
87 ************************************************************************
88
89 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
90 it needs to know something about the {\em usage} of the things bound,
91 so that it can create specialisations of them. So @tcBindsAndThen@
92 takes a function which, given an extended environment, E, typechecks
93 the scope of the bindings returning a typechecked thing and (most
94 important) an LIE. It is this LIE which is then used as the basis for
95 specialising the things bound.
96
97 @tcBindsAndThen@ also takes a "combiner" which glues together the
98 bindings and the "thing" to make a new "thing".
99
100 The real work is done by @tcBindWithSigsAndThen@.
101
102 Recursive and non-recursive binds are handled in essentially the same
103 way: because of uniques there are no scoping issues left. The only
104 difference is that non-recursive bindings can bind primitive values.
105
106 Even for non-recursive binding groups we add typings for each binder
107 to the LVE for the following reason. When each individual binding is
108 checked the type of its LHS is unified with that of its RHS; and
109 type-checking the LHS of course requires that the binder is in scope.
110
111 At the top-level the LIE is sure to contain nothing but constant
112 dictionaries, which we resolve at the module level.
113
114 Note [Polymorphic recursion]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 The game plan for polymorphic recursion in the code above is
117
118 * Bind any variable for which we have a type signature
119 to an Id with a polymorphic type. Then when type-checking
120 the RHSs we'll make a full polymorphic call.
121
122 This fine, but if you aren't a bit careful you end up with a horrendous
123 amount of partial application and (worse) a huge space leak. For example:
124
125 f :: Eq a => [a] -> [a]
126 f xs = ...f...
127
128 If we don't take care, after typechecking we get
129
130 f = /\a -> \d::Eq a -> let f' = f a d
131 in
132 \ys:[a] -> ...f'...
133
134 Notice the the stupid construction of (f a d), which is of course
135 identical to the function we're executing. In this case, the
136 polymorphic recursion isn't being used (but that's a very common case).
137 This can lead to a massive space leak, from the following top-level defn
138 (post-typechecking)
139
140 ff :: [Int] -> [Int]
141 ff = f Int dEqInt
142
143 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
144 f' is another thunk which evaluates to the same thing... and you end
145 up with a chain of identical values all hung onto by the CAF ff.
146
147 ff = f Int dEqInt
148
149 = let f' = f Int dEqInt in \ys. ...f'...
150
151 = let f' = let f' = f Int dEqInt in \ys. ...f'...
152 in \ys. ...f'...
153
154 Etc.
155
156 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
157 which would make the space leak go away in this case
158
159 Solution: when typechecking the RHSs we always have in hand the
160 *monomorphic* Ids for each binding. So we just need to make sure that
161 if (Method f a d) shows up in the constraints emerging from (...f...)
162 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
163 to the "givens" when simplifying constraints. That's what the "lies_avail"
164 is doing.
165
166 Then we get
167
168 f = /\a -> \d::Eq a -> letrec
169 fm = \ys:[a] -> ...fm...
170 in
171 fm
172 -}
173
174 tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv)
175 -- The TcGblEnv contains the new tcg_binds and tcg_spects
176 -- The TcLclEnv has an extended type envt for the new bindings
177 tcTopBinds binds sigs
178 = do { -- Pattern synonym bindings populate the global environment
179 (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
180 do { gbl <- getGblEnv
181 ; lcl <- getLclEnv
182 ; return (gbl, lcl) }
183 ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
184
185 ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env }
186 `addTypecheckedBinds` map snd binds' }
187
188 ; return (tcg_env', tcl_env) }
189 -- The top level bindings are flattened into a giant
190 -- implicitly-mutually-recursive LHsBinds
191
192 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
193 tcRecSelBinds (ValBindsOut binds sigs)
194 = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
195 do { (rec_sel_binds, tcg_env) <- discardWarnings $
196 tcValBinds TopLevel binds sigs getGblEnv
197 ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
198 ; return tcg_env' }
199 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
200
201 tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id]
202 -- A hs-boot file has only one BindGroup, and it only has type
203 -- signatures in it. The renamer checked all this
204 tcHsBootSigs binds sigs
205 = do { checkTc (null binds) badBootDeclErr
206 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
207 where
208 tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames
209 where
210 f (L _ name)
211 = do { sigma_ty <- solveEqualities $
212 tcHsSigWcType (FunSigCtxt name False) hs_ty
213 ; return (mkVanillaGlobal name sigma_ty) }
214 -- Notice that we make GlobalIds, not LocalIds
215 tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
216
217 badBootDeclErr :: MsgDoc
218 badBootDeclErr = text "Illegal declarations in an hs-boot file"
219
220 ------------------------
221 tcLocalBinds :: HsLocalBinds Name -> TcM thing
222 -> TcM (HsLocalBinds TcId, thing)
223
224 tcLocalBinds EmptyLocalBinds thing_inside
225 = do { thing <- thing_inside
226 ; return (EmptyLocalBinds, thing) }
227
228 tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
229 = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
230 ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
231 tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
232
233 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
234 = do { ipClass <- tcLookupClass ipClassName
235 ; (given_ips, ip_binds') <-
236 mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
237
238 -- If the binding binds ?x = E, we must now
239 -- discharge any ?x constraints in expr_lie
240 -- See Note [Implicit parameter untouchables]
241 ; (ev_binds, result) <- checkConstraints (IPSkol ips)
242 [] given_ips thing_inside
243
244 ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
245 where
246 ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]
247
248 -- I wonder if we should do these one at at time
249 -- Consider ?x = 4
250 -- ?y = ?x + 1
251 tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)
252 = do { ty <- newOpenFlexiTyVarTy
253 ; let p = mkStrLitTy $ hsIPNameFS ip
254 ; ip_id <- newDict ipClass [ p, ty ]
255 ; expr' <- tcMonoExpr expr ty
256 ; let d = toDict ipClass p ty `fmap` expr'
257 ; return (ip_id, (IPBind (Right ip_id) d)) }
258 tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
259
260 -- Coerces a `t` into a dictionry for `IP "x" t`.
261 -- co : t -> IP "x" t
262 toDict ipClass x ty = HsWrap $ mkWpCastR $
263 wrapIP $ mkClassPred ipClass [x,ty]
264
265 {- Note [Implicit parameter untouchables]
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 We add the type variables in the types of the implicit parameters
268 as untouchables, not so much because we really must not unify them,
269 but rather because we otherwise end up with constraints like this
270 Num alpha, Implic { wanted = alpha ~ Int }
271 The constraint solver solves alpha~Int by unification, but then
272 doesn't float that solved constraint out (it's not an unsolved
273 wanted). Result disaster: the (Num alpha) is again solved, this
274 time by defaulting. No no no.
275
276 However [Oct 10] this is all handled automatically by the
277 untouchable-range idea.
278
279 Note [Inlining and hs-boot files]
280 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
281 Consider this example (Trac #10083):
282
283 ---------- RSR.hs-boot ------------
284 module RSR where
285 data RSR
286 eqRSR :: RSR -> RSR -> Bool
287
288 ---------- SR.hs ------------
289 module SR where
290 import {-# SOURCE #-} RSR
291 data SR = MkSR RSR
292 eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
293
294 ---------- RSR.hs ------------
295 module RSR where
296 import SR
297 data RSR = MkRSR SR -- deriving( Eq )
298 eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
299 foo x y = not (eqRSR x y)
300
301 When compiling RSR we get this code
302
303 RSR.eqRSR :: RSR -> RSR -> Bool
304 RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->
305 case ds1 of _ { RSR.MkRSR s1 ->
306 case ds2 of _ { RSR.MkRSR s2 ->
307 SR.eqSR s1 s2 }}
308
309 RSR.foo :: RSR -> RSR -> Bool
310 RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)
311
312 Now, when optimising foo:
313 Inline eqRSR (small, non-rec)
314 Inline eqSR (small, non-rec)
315 but the result of inlining eqSR from SR is another call to eqRSR, so
316 everything repeats. Neither eqSR nor eqRSR are (apparently) loop
317 breakers.
318
319 Solution: when compiling RSR, add a NOINLINE pragma to every function
320 exported by the boot-file for RSR (if it exists).
321
322 ALAS: doing so makes the boostrappted GHC itself slower by 8% overall
323 (on Trac #9872a-d, and T1969. So I un-did this change, and
324 parked it for now. Sigh.
325 -}
326
327 tcValBinds :: TopLevelFlag
328 -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
329 -> TcM thing
330 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
331
332 tcValBinds top_lvl binds sigs thing_inside
333 = do { let patsyns = getPatSynBinds binds
334
335 -- Typecheck the signature
336 ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
337 tcTySigs sigs
338
339 ; _self_boot <- tcSelfBootInfo
340 ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
341
342 -- ------- See Note [Inlining and hs-boot files] (change parked) --------
343 -- prag_fn | isTopLevel top_lvl -- See Note [Inlining and hs-boot files]
344 -- , SelfBoot { sb_ids = boot_id_names } <- self_boot
345 -- = foldNameSet add_no_inl prag_fn1 boot_id_names
346 -- | otherwise
347 -- = prag_fn1
348 -- add_no_inl boot_id_name prag_fn
349 -- = extendPragEnv prag_fn (boot_id_name, no_inl_sig boot_id_name)
350 -- no_inl_sig name = L boot_loc (InlineSig (L boot_loc name) neverInlinePragma)
351 -- boot_loc = mkGeneralSrcSpan (fsLit "The hs-boot file for this module")
352
353 -- Extend the envt right away with all the Ids
354 -- declared with complete type signatures
355 -- Do not extend the TcIdBinderStack; instead
356 -- we extend it on a per-rhs basis in tcExtendForRhs
357 ; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $ do
358 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
359 { thing <- thing_inside
360 -- See Note [Pattern synonym builders don't yield dependencies]
361 ; patsyn_builders <- mapM (tcPatSynBuilderBind sig_fn) patsyns
362 ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
363 ; return (extra_binds, thing) }
364 ; return (binds' ++ extra_binds', thing) }}
365
366 ------------------------
367 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
368 -> [(RecFlag, LHsBinds Name)] -> TcM thing
369 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
370 -- Typecheck a whole lot of value bindings,
371 -- one strongly-connected component at a time
372 -- Here a "strongly connected component" has the strightforward
373 -- meaning of a group of bindings that mention each other,
374 -- ignoring type signatures (that part comes later)
375
376 tcBindGroups _ _ _ [] thing_inside
377 = do { thing <- thing_inside
378 ; return ([], thing) }
379
380 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
381 = do { (group', (groups', thing))
382 <- tc_group top_lvl sig_fn prag_fn group $
383 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
384 ; return (group' ++ groups', thing) }
385
386 ------------------------
387 tc_group :: forall thing.
388 TopLevelFlag -> TcSigFun -> TcPragEnv
389 -> (RecFlag, LHsBinds Name) -> TcM thing
390 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
391
392 -- Typecheck one strongly-connected component of the original program.
393 -- We get a list of groups back, because there may
394 -- be specialisations etc as well
395
396 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
397 -- A single non-recursive binding
398 -- We want to keep non-recursive things non-recursive
399 -- so that we desugar unlifted bindings correctly
400 = do { let bind = case bagToList binds of
401 [bind] -> bind
402 [] -> panic "tc_group: empty list of binds"
403 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
404 ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
405 ; return ( [(NonRecursive, bind')], thing) }
406
407 tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
408 = -- To maximise polymorphism, we do a new
409 -- strongly-connected-component analysis, this time omitting
410 -- any references to variables with type signatures.
411 -- (This used to be optional, but isn't now.)
412 -- See Note [Polymorphic recursion] in HsBinds.
413 do { traceTc "tc_group rec" (pprLHsBinds binds)
414 ; when hasPatSyn $ recursivePatSynErr binds
415 ; (binds1, thing) <- go sccs
416 ; return ([(Recursive, binds1)], thing) }
417 -- Rec them all together
418 where
419 hasPatSyn = anyBag (isPatSyn . unLoc) binds
420 isPatSyn PatSynBind{} = True
421 isPatSyn _ = False
422
423 sccs :: [SCC (LHsBind Name)]
424 sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
425
426 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
427 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
428 ; (binds2, thing) <- tcExtendLetEnv top_lvl ids1 $
429 go sccs
430 ; return (binds1 `unionBags` binds2, thing) }
431 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
432
433 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
434 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
435
436 tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
437
438 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
439 recursivePatSynErr binds
440 = failWithTc $
441 hang (text "Recursive pattern synonym definition with following bindings:")
442 2 (vcat $ map pprLBind . bagToList $ binds)
443 where
444 pprLoc loc = parens (text "defined at" <+> ppr loc)
445 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
446 pprLoc loc
447
448 tc_single :: forall thing.
449 TopLevelFlag -> TcSigFun -> TcPragEnv
450 -> LHsBind Name -> TcM thing
451 -> TcM (LHsBinds TcId, thing)
452 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
453 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
454 ; thing <- setGblEnv tcg_env thing_inside
455 ; return (aux_binds, thing)
456 }
457 where
458 tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)
459 tc_pat_syn_decl = case sig_fn name of
460 Nothing -> tcInferPatSynDecl psb
461 Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
462 Just _ -> panic "tc_single"
463
464 tc_single top_lvl sig_fn prag_fn lbind thing_inside
465 = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
466 NonRecursive NonRecursive
467 [lbind]
468 ; thing <- tcExtendLetEnv top_lvl ids thing_inside
469 ; return (binds1, thing) }
470
471 ------------------------
472 type BKey = Int -- Just number off the bindings
473
474 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
475 -- See Note [Polymorphic recursion] in HsBinds.
476 mkEdges sig_fn binds
477 = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),
478 Just key <- [lookupNameEnv key_map n], no_sig n ])
479 | (bind, key) <- keyd_binds
480 ]
481 where
482 no_sig :: Name -> Bool
483 no_sig n = noCompleteSig (sig_fn n)
484
485 keyd_binds = bagToList binds `zip` [0::BKey ..]
486
487 key_map :: NameEnv BKey -- Which binding it comes from
488 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
489 , bndr <- collectHsBindBinders bind ]
490
491 ------------------------
492 tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
493 -> RecFlag -- Whether the group is really recursive
494 -> RecFlag -- Whether it's recursive after breaking
495 -- dependencies based on type signatures
496 -> [LHsBind Name] -- None are PatSynBind
497 -> TcM (LHsBinds TcId, [TcId])
498
499 -- Typechecks a single bunch of values bindings all together,
500 -- and generalises them. The bunch may be only part of a recursive
501 -- group, because we use type signatures to maximise polymorphism
502 --
503 -- Returns a list because the input may be a single non-recursive binding,
504 -- in which case the dependency order of the resulting bindings is
505 -- important.
506 --
507 -- Knows nothing about the scope of the bindings
508 -- None of the bindings are pattern synonyms
509
510 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
511 = setSrcSpan loc $
512 recoverM (recoveryCode binder_names sig_fn) $ do
513 -- Set up main recover; take advantage of any type sigs
514
515 { traceTc "------------------------------------------------" Outputable.empty
516 ; traceTc "Bindings for {" (ppr binder_names)
517 ; dflags <- getDynFlags
518 ; type_env <- getLclTypeEnv
519 ; let plan = decideGeneralisationPlan dflags type_env
520 binder_names bind_list sig_fn
521 ; traceTc "Generalisation plan" (ppr plan)
522 ; result@(tc_binds, poly_ids) <- case plan of
523 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
524 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
525 CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind
526
527 -- Check whether strict bindings are ok
528 -- These must be non-recursive etc, and are not generalised
529 -- They desugar to a case expression in the end
530 ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
531 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
532 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
533 ])
534
535 ; return result }
536 where
537 binder_names = collectHsBindListBinders bind_list
538 loc = foldr1 combineSrcSpans (map getLoc bind_list)
539 -- The mbinds have been dependency analysed and
540 -- may no longer be adjacent; so find the narrowest
541 -- span that includes them all
542
543 ------------------
544 tcPolyNoGen -- No generalisation whatsoever
545 :: RecFlag -- Whether it's recursive after breaking
546 -- dependencies based on type signatures
547 -> TcPragEnv -> TcSigFun
548 -> [LHsBind Name]
549 -> TcM (LHsBinds TcId, [TcId])
550
551 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
552 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
553 (LetGblBndr prag_fn)
554 bind_list
555 ; mono_ids' <- mapM tc_mono_info mono_infos
556 ; return (binds', mono_ids') }
557 where
558 tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
559 = do { mono_ty' <- zonkTcType (idType mono_id)
560 -- Zonk, mainly to expose unboxed types to checkStrictBinds
561 ; let mono_id' = setIdType mono_id mono_ty'
562 ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)
563 ; return mono_id' }
564 -- NB: tcPrags generates error messages for
565 -- specialisation pragmas for non-overloaded sigs
566 -- Indeed that is why we call it here!
567 -- So we can safely ignore _specs
568
569 ------------------
570 tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
571 -- dependencies based on type signatures
572 -> TcPragEnv
573 -> TcIdSigInfo
574 -> LHsBind Name
575 -> TcM (LHsBinds TcId, [TcId])
576 -- There is just one binding,
577 -- it binds a single variable,
578 -- it has a complete type signature,
579 tcPolyCheck rec_tc prag_fn
580 sig@(TISI { sig_bndr = CompleteSig poly_id
581 , sig_skols = skol_prs
582 , sig_theta = theta
583 , sig_tau = tau
584 , sig_ctxt = ctxt
585 , sig_loc = loc })
586 bind
587 = do { ev_vars <- newEvVars theta
588 ; let skol_info = SigSkol ctxt (mkPhiTy theta tau)
589 prag_sigs = lookupPragEnv prag_fn name
590 skol_tvs = map snd skol_prs
591 -- Find the location of the original source type sig, if
592 -- there is was one. This will appear in messages like
593 -- "type variable x is bound by .. at <loc>"
594 name = idName poly_id
595 ; (ev_binds, (binds', _))
596 <- setSrcSpan loc $
597 checkConstraints skol_info skol_tvs ev_vars $
598 tcMonoBinds rec_tc (\_ -> Just (TcIdSig sig)) LetLclBndr [bind]
599
600 ; spec_prags <- tcSpecPrags poly_id prag_sigs
601 ; poly_id <- addInlinePrags poly_id prag_sigs
602
603 ; let bind' = case bagToList binds' of
604 [b] -> b
605 _ -> pprPanic "tcPolyCheck" (ppr binds')
606 abs_bind = L loc $ AbsBindsSig
607 { abs_tvs = skol_tvs
608 , abs_ev_vars = ev_vars
609 , abs_sig_export = poly_id
610 , abs_sig_prags = SpecPrags spec_prags
611 , abs_sig_ev_bind = ev_binds
612 , abs_sig_bind = bind' }
613
614 ; return (unitBag abs_bind, [poly_id]) }
615
616 tcPolyCheck _rec_tc _prag_fn sig _bind
617 = pprPanic "tcPolyCheck" (ppr sig)
618
619 ------------------
620 {-
621 Note [Instantiate when inferring a type]
622 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
623 Consider
624 f = (*)
625 As there is no incentive to instantiate the RHS, tcMonoBinds will
626 produce a type of forall a. Num a => a -> a -> a for `f`. This will then go
627 through simplifyInfer and such, remaining unchanged.
628
629 There are two problems with this:
630 1) If the definition were `g _ = (*)`, we get a very unusual type of
631 `forall {a}. a -> forall b. Num b => b -> b -> b` for `g`. This is
632 surely confusing for users.
633
634 2) The monomorphism restriction can't work. The MR is dealt with in
635 simplifyInfer, and simplifyInfer has no way of instantiating. This
636 could perhaps be worked around, but it may be hard to know even
637 when instantiation should happen.
638
639 There is an easy solution to all three problems: instantiate (deeply) when
640 inferring a type. So that's what we do. Note that this decision is
641 user-facing.
642
643 Here are the details:
644 * tcMonoBinds produces the "monomorphic" ids to be put in the AbsBinds.
645 It is inconvenient to instantiate in this function or below. So the
646 monomorphic ids will be uninstantiated (and hence actually polymorphic,
647 but that doesn't ruin anyone's day).
648
649 * In the same captureConstraints as the tcMonoBinds, we instantiate all
650 the types of the monomorphic ids. Instantiating will produce constraints
651 to solve and instantiated types. These constraints and the instantiated
652 types go into simplifyInfer. HsWrappers are produced that go from
653 the "mono" types to the instantiated ones.
654
655 * simplifyInfer does its magic, figuring out how to regeneralize.
656
657 * mkExport then does the impedence matching and needs to connect the
658 monomorphic ids to the polymorphic types as decided by simplifyInfer.
659 Because the instantiation happens before simplifyInfer, we also pass in
660 the HsWrappers obtained via instantiating so that mkExport can connect
661 all the pieces.
662
663 * We produce an AbsBinds with the right (instantiated and then, perhaps,
664 regeneralized) polytypes and the not-yet-instantiated "monomorphic" ids,
665 using the built HsWrappers to connect. Done!
666 -}
667
668 tcPolyInfer
669 :: RecFlag -- Whether it's recursive after breaking
670 -- dependencies based on type signatures
671 -> TcPragEnv -> TcSigFun
672 -> Bool -- True <=> apply the monomorphism restriction
673 -> [LHsBind Name]
674 -> TcM (LHsBinds TcId, [TcId])
675 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
676 = do { (tclvl, wanted, (binds', mono_infos, wrappers, insted_tys))
677 <- pushLevelAndCaptureConstraints $
678 do { (binds', mono_infos)
679 <- tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
680 -- See Note [Instantiate when inferring a type]
681 ; traceTc "Note [Instantiate when inferring a type]" $
682 vcat (map (pprBndr LetBind . mbi_mono_id) mono_infos)
683 ; (wrappers, insted_tys)
684 <- tcExtendIdBndrs
685 [ TcIdBndr mono_id NotTopLevel
686 | MBI { mbi_mono_id = mono_id } <- mono_infos ] $
687 mapAndUnzipM deeply_instantiate mono_infos
688 -- during instantiation, we might encounter an error
689 -- whose message will want to list these binders as
690 -- relevant.
691
692 ; return (binds', mono_infos, wrappers, insted_tys) }
693
694 ; let name_taus = [ (mbi_poly_name info, tau)
695 | (info, tau) <- zip mono_infos insted_tys]
696 sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
697
698 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
699 ; (qtvs, givens, ev_binds)
700 <- simplifyInfer tclvl mono sigs name_taus wanted
701
702 ; let inferred_theta = map evVarPred givens
703 ; exports <- checkNoErrs $
704 zipWith3M (mkExport prag_fn qtvs inferred_theta)
705 mono_infos wrappers insted_tys
706
707 ; loc <- getSrcSpanM
708 ; let poly_ids = map abe_poly exports
709 abs_bind = L loc $
710 AbsBinds { abs_tvs = qtvs
711 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
712 , abs_exports = exports, abs_binds = binds' }
713
714 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
715 ; return (unitBag abs_bind, poly_ids) }
716 -- poly_ids are guaranteed zonked by mkExport
717
718 where
719 deeply_instantiate :: MonoBindInfo -> TcM (HsWrapper, TcRhoType)
720 deeply_instantiate (MBI { mbi_mono_id = mono_id, mbi_orig = orig })
721 = do { mono_ty <- zonkTcType (idType mono_id)
722 -- NB: zonk to uncover any foralls
723 ; addErrCtxtM (instErrCtxt mono_id mono_ty) $
724 deeplyInstantiate orig mono_ty }
725
726 --------------
727 mkExport :: TcPragEnv
728 -> [TyVar] -> TcThetaType -- Both already zonked
729 -> MonoBindInfo
730 -> HsWrapper -- the instantiation wrapper;
731 -- see Note [Instantiate when inferring a type]
732 -> TcTauType -- the instantiated type
733 -> TcM (ABExport Id)
734 -- Only called for generalisation plan InferGen, not by CheckGen or NoGen
735 --
736 -- mkExport generates exports with
737 -- zonked type variables,
738 -- zonked poly_ids
739 -- The former is just because no further unifications will change
740 -- the quantified type variables, so we can fix their final form
741 -- right now.
742 -- The latter is needed because the poly_ids are used to extend the
743 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
744
745 -- Pre-condition: the qtvs and theta are already zonked
746
747 mkExport prag_fn qtvs theta
748 mono_info@(MBI { mbi_poly_name = poly_name
749 , mbi_sig = mb_sig
750 , mbi_mono_id = mono_id })
751 inst_wrap inst_ty
752 = do { inst_ty <- zonkTcType inst_ty
753
754 ; poly_id <- case mb_sig of
755 Just sig | Just poly_id <- completeIdSigPolyId_maybe sig
756 -> return poly_id
757 _other -> checkNoErrs $
758 mkInferredPolyId qtvs theta
759 poly_name mb_sig inst_ty
760 -- The checkNoErrs ensures that if the type is ambiguous
761 -- we don't carry on to the impedence matching, and generate
762 -- a duplicate ambiguity error. There is a similar
763 -- checkNoErrs for complete type signatures too.
764
765 -- NB: poly_id has a zonked type
766 ; poly_id <- addInlinePrags poly_id prag_sigs
767 ; spec_prags <- tcSpecPrags poly_id prag_sigs
768 -- tcPrags requires a zonked poly_id
769
770 -- See Note [Impedence matching]
771 -- NB: we have already done checkValidType, including an ambiguity check,
772 -- on the type; either when we checked the sig or in mkInferredPolyId
773 ; let sel_poly_ty = mkInvSigmaTy qtvs theta inst_ty
774 -- this type is just going into tcSubType, so Inv vs. Spec doesn't
775 -- matter
776
777 poly_ty = idType poly_id
778 ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility
779 then return idHsWrapper -- Fast path; also avoids complaint when we infer
780 -- an ambiguouse type and have AllowAmbiguousType
781 -- e..g infer x :: forall a. F a -> Int
782 else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
783 tcSubType_NC sig_ctxt sel_poly_ty poly_ty
784
785 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
786 ; when warn_missing_sigs $ localSigWarn poly_id mb_sig
787
788 ; return (ABE { abe_wrap = wrap
789 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => inst_ty)
790 , abe_inst_wrap = inst_wrap
791 , abe_poly = poly_id
792 , abe_mono = mono_id
793 , abe_prags = SpecPrags spec_prags}) }
794 where
795 prag_sigs = lookupPragEnv prag_fn poly_name
796 sig_ctxt = InfSigCtxt poly_name
797
798 mkInferredPolyId :: [TyVar] -> TcThetaType
799 -> Name -> Maybe TcIdSigInfo -> TcType
800 -> TcM TcId
801 mkInferredPolyId qtvs inferred_theta poly_name mb_sig mono_ty
802 = do { fam_envs <- tcGetFamInstEnvs
803 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
804 -- Unification may not have normalised the type,
805 -- (see Note [Lazy flattening] in TcFlatten) so do it
806 -- here to make it as uncomplicated as possible.
807 -- Example: f :: [F Int] -> Bool
808 -- should be rewritten to f :: [Char] -> Bool, if possible
809 --
810 -- We can discard the coercion _co, because we'll reconstruct
811 -- it in the call to tcSubType below
812
813 ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
814 (tyCoVarsOfType mono_ty') qtvs mb_sig
815
816 ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
817
818 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
819 , ppr inferred_poly_ty])
820 ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
821 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
822 -- See Note [Validity of inferred types]
823
824 ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
825
826
827 chooseInferredQuantifiers :: TcThetaType -- inferred
828 -> TcTyVarSet -- tvs free in tau type
829 -> [TcTyVar] -- inferred quantified tvs
830 -> Maybe TcIdSigInfo
831 -> TcM ([TcTyBinder], TcThetaType)
832 chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
833 = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
834 -- Include kind variables! Trac #7916
835 my_theta = pickQuantifiablePreds free_tvs inferred_theta
836 binders = [ mkNamedBinder tv Invisible
837 | tv <- qtvs
838 , tv `elemVarSet` free_tvs ]
839 ; return (binders, my_theta) }
840
841 chooseInferredQuantifiers inferred_theta tau_tvs qtvs
842 (Just (TISI { sig_bndr = bndr_info
843 , sig_ctxt = ctxt
844 , sig_theta = annotated_theta
845 , sig_skols = annotated_tvs }))
846 | PartialSig { sig_cts = extra } <- bndr_info
847 , Nothing <- extra
848 = do { annotated_theta <- zonkTcTypes annotated_theta
849 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
850 `unionVarSet` tau_tvs)
851 ; traceTc "ciq" (vcat [ ppr bndr_info, ppr annotated_theta, ppr free_tvs])
852 ; return (mk_binders free_tvs, annotated_theta) }
853
854 | PartialSig { sig_cts = extra } <- bndr_info
855 , Just loc <- extra
856 = do { annotated_theta <- zonkTcTypes annotated_theta
857 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
858 `unionVarSet` tau_tvs)
859 my_theta = pickQuantifiablePreds free_tvs inferred_theta
860
861 -- Report the inferred constraints for an extra-constraints wildcard/hole as
862 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
863 -- case, the extra inferred constraints are accepted without complaining.
864 -- Returns the annotated constraints combined with the inferred constraints.
865 inferred_diff = [ pred
866 | pred <- my_theta
867 , all (not . (`eqType` pred)) annotated_theta ]
868 final_theta = annotated_theta ++ inferred_diff
869 ; partial_sigs <- xoptM LangExt.PartialTypeSignatures
870 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
871 ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
872 ; traceTc "completeTheta" $
873 vcat [ ppr bndr_info
874 , ppr annotated_theta, ppr inferred_theta
875 , ppr inferred_diff ]
876 ; case partial_sigs of
877 True | warn_partial_sigs -> reportWarning msg
878 | otherwise -> return ()
879 False -> reportError msg
880
881 ; return (mk_binders free_tvs, final_theta) }
882
883 | otherwise = pprPanic "chooseInferredQuantifiers" (ppr bndr_info)
884
885 where
886 pts_hint = text "To use the inferred type, enable PartialTypeSignatures"
887 mk_msg inferred_diff suppress_hint
888 = vcat [ hang ((text "Found constraint wildcard") <+> quotes (char '_'))
889 2 (text "standing for") <+> quotes (pprTheta inferred_diff)
890 , if suppress_hint then empty else pts_hint
891 , typeSigCtxt ctxt bndr_info ]
892
893 spec_tv_set = mkVarSet $ map snd annotated_tvs
894 mk_binders free_tvs
895 = [ mkNamedBinder tv vis
896 | tv <- qtvs
897 , tv `elemVarSet` free_tvs
898 , let vis | tv `elemVarSet` spec_tv_set = Specified
899 | otherwise = Invisible ]
900 -- Pulling from qtvs maintains original order
901
902 mk_impedence_match_msg :: MonoBindInfo
903 -> TcType -> TcType
904 -> TidyEnv -> TcM (TidyEnv, SDoc)
905 -- This is a rare but rather awkward error messages
906 mk_impedence_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
907 inf_ty sig_ty tidy_env
908 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
909 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
910 ; let msg = vcat [ text "When checking that the inferred type"
911 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
912 , text "is as general as its" <+> what <+> text "signature"
913 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
914 ; return (tidy_env2, msg) }
915 where
916 what = case mb_sig of
917 Nothing -> text "inferred"
918 Just sig | isPartialSig sig -> text "(partial)"
919 | otherwise -> empty
920
921
922 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
923 mk_inf_msg poly_name poly_ty tidy_env
924 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
925 ; let msg = vcat [ text "When checking the inferred type"
926 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
927 ; return (tidy_env1, msg) }
928
929
930 -- | Warn the user about polymorphic local binders that lack type signatures.
931 localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM ()
932 localSigWarn id mb_sig
933 | Just _ <- mb_sig = return ()
934 | not (isSigmaTy (idType id)) = return ()
935 | otherwise = warnMissingSig msg id
936 where
937 msg = text "Polymorphic local binding with no type signature:"
938
939 warnMissingSig :: SDoc -> Id -> TcM ()
940 warnMissingSig msg id
941 = do { env0 <- tcInitTidyEnv
942 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
943 ; addWarnTcM (env1, mk_msg tidy_ty) }
944 where
945 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
946
947 {-
948 Note [Partial type signatures and generalisation]
949 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
950 When we have a partial type signature, like
951 f :: _ -> Int
952 then we *always* use the InferGen plan, and hence tcPolyInfer.
953 We do this even for a local binding with -XMonoLocalBinds.
954 Reasons:
955 * The TcSigInfo for 'f' has a unification variable for the '_',
956 whose TcLevel is one level deeper than the current level.
957 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
958 the TcLevel like InferGen, so we lose the level invariant.
959
960 * The signature might be f :: forall a. _ -> a
961 so it really is polymorphic. It's not clear what it would
962 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
963 in the (Just sig) case, checks that if there is a signature
964 then we are using LetLclBndr, and hence a nested AbsBinds with
965 increased TcLevel
966
967 It might be possible to fix these difficulties somehow, but there
968 doesn't seem much point. Indeed, adding a partial type signature is a
969 way to get per-binding inferred generalisation.
970
971 Note [Validity of inferred types]
972 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
973 We need to check inferred type for validity, in case it uses language
974 extensions that are not turned on. The principle is that if the user
975 simply adds the inferred type to the program source, it'll compile fine.
976 See #8883.
977
978 Examples that might fail:
979 - the type might be ambiguous
980
981 - an inferred theta that requires type equalities e.g. (F a ~ G b)
982 or multi-parameter type classes
983 - an inferred type that includes unboxed tuples
984
985
986 Note [Impedence matching]
987 ~~~~~~~~~~~~~~~~~~~~~~~~~
988 Consider
989 f 0 x = x
990 f n x = g [] (not x)
991
992 g [] y = f 10 y
993 g _ y = f 9 y
994
995 After typechecking we'll get
996 f_mono_ty :: a -> Bool -> Bool
997 g_mono_ty :: [b] -> Bool -> Bool
998 with constraints
999 (Eq a, Num a)
1000
1001 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
1002 The types we really want for f and g are
1003 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
1004 g :: forall b. [b] -> Bool -> Bool
1005
1006 We can get these by "impedance matching":
1007 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
1008 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
1009
1010 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
1011 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
1012
1013 Suppose the shared quantified tyvars are qtvs and constraints theta.
1014 Then we want to check that
1015 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1016 and the proof is the impedance matcher.
1017
1018 Notice that the impedance matcher may do defaulting. See Trac #7173.
1019
1020 It also cleverly does an ambiguity check; for example, rejecting
1021 f :: F a -> F a
1022 where F is a non-injective type function.
1023 -}
1024
1025 --------------
1026 -- If typechecking the binds fails, then return with each
1027 -- signature-less binder given type (forall a.a), to minimise
1028 -- subsequent error messages
1029 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
1030 recoveryCode binder_names sig_fn
1031 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
1032 ; let poly_ids = map mk_dummy binder_names
1033 ; return (emptyBag, poly_ids) }
1034 where
1035 mk_dummy name
1036 | Just sig <- sig_fn name
1037 , Just poly_id <- completeSigPolyId_maybe sig
1038 = poly_id
1039 | otherwise
1040 = mkLocalId name forall_a_a
1041
1042 forall_a_a :: TcType
1043 forall_a_a = mkSpecForAllTys [levity1TyVar, openAlphaTyVar] openAlphaTy
1044
1045 {- *********************************************************************
1046 * *
1047 Pragmas, including SPECIALISE
1048 * *
1049 ************************************************************************
1050
1051 Note [Handling SPECIALISE pragmas]
1052 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1053 The basic idea is this:
1054
1055 foo :: Num a => a -> b -> a
1056 {-# SPECIALISE foo :: Int -> b -> Int #-}
1057
1058 We check that
1059 (forall a b. Num a => a -> b -> a)
1060 is more polymorphic than
1061 forall b. Int -> b -> Int
1062 (for which we could use tcSubType, but see below), generating a HsWrapper
1063 to connect the two, something like
1064 wrap = /\b. <hole> Int b dNumInt
1065 This wrapper is put in the TcSpecPrag, in the ABExport record of
1066 the AbsBinds.
1067
1068
1069 f :: (Eq a, Ix b) => a -> b -> Bool
1070 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
1071 f = <poly_rhs>
1072
1073 From this the typechecker generates
1074
1075 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
1076
1077 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
1078 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
1079
1080 From these we generate:
1081
1082 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
1083 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
1084
1085 Spec bind: f_spec = wrap_fn <poly_rhs>
1086
1087 Note that
1088
1089 * The LHS of the rule may mention dictionary *expressions* (eg
1090 $dfIxPair dp dq), and that is essential because the dp, dq are
1091 needed on the RHS.
1092
1093 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
1094 can fully specialise it.
1095
1096
1097
1098 From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:
1099
1100 f_spec :: Int -> b -> Int
1101 f_spec = wrap<f rhs>
1102
1103 RULE: forall b (d:Num b). f b d = f_spec b
1104
1105 The RULE is generated by taking apart the HsWrapper, which is a little
1106 delicate, but works.
1107
1108 Some wrinkles
1109
1110 1. We don't use full-on tcSubType, because that does co and contra
1111 variance and that in turn will generate too complex a LHS for the
1112 RULE. So we use a single invocation of skolemise /
1113 topInstantiate in tcSpecWrapper. (Actually I think that even
1114 the "deeply" stuff may be too much, because it introduces lambdas,
1115 though I think it can be made to work without too much trouble.)
1116
1117 2. We need to take care with type families (Trac #5821). Consider
1118 type instance F Int = Bool
1119 f :: Num a => a -> F a
1120 {-# SPECIALISE foo :: Int -> Bool #-}
1121
1122 We *could* try to generate an f_spec with precisely the declared type:
1123 f_spec :: Int -> Bool
1124 f_spec = <f rhs> Int dNumInt |> co
1125
1126 RULE: forall d. f Int d = f_spec |> sym co
1127
1128 but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
1129 hard to generate. At all costs we must avoid this:
1130 RULE: forall d. f Int d |> co = f_spec
1131 because the LHS will never match (indeed it's rejected in
1132 decomposeRuleLhs).
1133
1134 So we simply do this:
1135 - Generate a constraint to check that the specialised type (after
1136 skolemiseation) is equal to the instantiated function type.
1137 - But *discard* the evidence (coercion) for that constraint,
1138 so that we ultimately generate the simpler code
1139 f_spec :: Int -> F Int
1140 f_spec = <f rhs> Int dNumInt
1141
1142 RULE: forall d. f Int d = f_spec
1143 You can see this discarding happening in
1144
1145 3. Note that the HsWrapper can transform *any* function with the right
1146 type prefix
1147 forall ab. (Eq a, Ix b) => XXX
1148 regardless of XXX. It's sort of polymorphic in XXX. This is
1149 useful: we use the same wrapper to transform each of the class ops, as
1150 well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags
1151 -}
1152
1153 mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv
1154 mkPragEnv sigs binds
1155 = foldl extendPragEnv emptyNameEnv prs
1156 where
1157 prs = mapMaybe get_sig sigs
1158
1159 get_sig :: LSig Name -> Maybe (Name, LSig Name)
1160 get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl))
1161 get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl))
1162 get_sig _ = Nothing
1163
1164 add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
1165 | Inline <- inl_inline inl_prag
1166 -- add arity only for real INLINE pragmas, not INLINABLE
1167 = case lookupNameEnv ar_env n of
1168 Just ar -> inl_prag { inl_sat = Just ar }
1169 Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )
1170 -- There really should be a binding for every INLINE pragma
1171 inl_prag
1172 | otherwise
1173 = inl_prag
1174
1175 -- ar_env maps a local to the arity of its definition
1176 ar_env :: NameEnv Arity
1177 ar_env = foldrBag lhsBindArity emptyNameEnv binds
1178
1179 extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv
1180 extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
1181
1182 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
1183 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
1184 = extendNameEnv env (unLoc id) (matchGroupArity ms)
1185 lhsBindArity _ env = env -- PatBind/VarBind
1186
1187 ------------------
1188 tcSpecPrags :: Id -> [LSig Name]
1189 -> TcM [LTcSpecPrag]
1190 -- Add INLINE and SPECIALSE pragmas
1191 -- INLINE prags are added to the (polymorphic) Id directly
1192 -- SPECIALISE prags are passed to the desugarer via TcSpecPrags
1193 -- Pre-condition: the poly_id is zonked
1194 -- Reason: required by tcSubExp
1195 tcSpecPrags poly_id prag_sigs
1196 = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
1197 ; unless (null bad_sigs) warn_discarded_sigs
1198 ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
1199 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
1200 where
1201 spec_sigs = filter isSpecLSig prag_sigs
1202 bad_sigs = filter is_bad_sig prag_sigs
1203 is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
1204
1205 warn_discarded_sigs
1206 = addWarnTc (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)
1207 2 (vcat (map (ppr . getLoc) bad_sigs)))
1208
1209 --------------
1210 tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag]
1211 tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
1212 -- See Note [Handling SPECIALISE pragmas]
1213 --
1214 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
1215 -- Example: SPECIALISE for a class method: the Name in the SpecSig is
1216 -- for the selector Id, but the poly_id is something like $cop
1217 -- However we want to use fun_name in the error message, since that is
1218 -- what the user wrote (Trac #8537)
1219 = addErrCtxt (spec_ctxt prag) $
1220 do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
1221 (text "SPECIALISE pragma for non-overloaded function"
1222 <+> quotes (ppr fun_name))
1223 -- Note [SPECIALISE pragmas]
1224 ; spec_prags <- mapM tc_one hs_tys
1225 ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))
1226 ; return spec_prags }
1227 where
1228 name = idName poly_id
1229 poly_ty = idType poly_id
1230 spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
1231
1232 tc_one hs_ty
1233 = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty
1234 ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty
1235 ; return (SpecPrag poly_id wrap inl) }
1236
1237 tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
1238
1239 --------------
1240 tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
1241 -- A simpler variant of tcSubType, used for SPECIALISE pragmas
1242 -- See Note [Handling SPECIALISE pragmas], wrinkle 1
1243 tcSpecWrapper ctxt poly_ty spec_ty
1244 = do { (sk_wrap, inst_wrap)
1245 <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->
1246 do { (inst_wrap, tau) <- topInstantiate orig poly_ty
1247 ; _ <- unifyType noThing spec_tau tau
1248 -- Deliberately ignore the evidence
1249 -- See Note [Handling SPECIALISE pragmas],
1250 -- wrinkle (2)
1251 ; return inst_wrap }
1252 ; return (sk_wrap <.> inst_wrap) }
1253 where
1254 orig = SpecPragOrigin ctxt
1255
1256 --------------
1257 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
1258 -- SPECIALISE pragmas for imported things
1259 tcImpPrags prags
1260 = do { this_mod <- getModule
1261 ; dflags <- getDynFlags
1262 ; if (not_specialising dflags) then
1263 return []
1264 else do
1265 { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
1266 [L loc (name,prag)
1267 | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
1268 , not (nameIsLocalOrFrom this_mod name) ]
1269 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
1270 where
1271 -- Ignore SPECIALISE pragmas for imported things
1272 -- when we aren't specialising, or when we aren't generating
1273 -- code. The latter happens when Haddocking the base library;
1274 -- we don't wnat complaints about lack of INLINABLE pragmas
1275 not_specialising dflags
1276 | not (gopt Opt_Specialise dflags) = True
1277 | otherwise = case hscTarget dflags of
1278 HscNothing -> True
1279 HscInterpreted -> True
1280 _other -> False
1281
1282 tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
1283 tcImpSpec (name, prag)
1284 = do { id <- tcLookupId name
1285 ; unless (isAnyInlinePragma (idInlinePragma id))
1286 (addWarnTc (impSpecErr name))
1287 ; tcSpecPrag id prag }
1288
1289 impSpecErr :: Name -> SDoc
1290 impSpecErr name
1291 = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))
1292 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma"
1293 , parens $ sep
1294 [ text "or its defining module" <+> quotes (ppr mod)
1295 , text "was compiled without -O"]])
1296 where
1297 mod = nameModule name
1298
1299
1300 {- *********************************************************************
1301 * *
1302 Vectorisation
1303 * *
1304 ********************************************************************* -}
1305
1306 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1307 tcVectDecls decls
1308 = do { decls' <- mapM (wrapLocM tcVect) decls
1309 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1310 dups = findDupsEq (==) ids
1311 ; mapM_ reportVectDups dups
1312 ; traceTcConstraints "End of tcVectDecls"
1313 ; return decls'
1314 }
1315 where
1316 reportVectDups (first:_second:_more)
1317 = addErrAt (getSrcSpan first) $
1318 text "Duplicate vectorisation declarations for" <+> ppr first
1319 reportVectDups _ = return ()
1320
1321 --------------
1322 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1323 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1324 -- type of the original definition as this requires internals of the vectoriser not available
1325 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1326 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1327 -- from the vectoriser here.
1328 tcVect (HsVect s name rhs)
1329 = addErrCtxt (vectCtxt name) $
1330 do { var <- wrapLocM tcLookupId name
1331 ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
1332 ; rhs_id <- tcLookupId rhs_var_name
1333 ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
1334 }
1335
1336 {- OLD CODE:
1337 -- turn the vectorisation declaration into a single non-recursive binding
1338 ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
1339 sigFun = const Nothing
1340 pragFun = emptyPragEnv
1341
1342 -- perform type inference (including generalisation)
1343 ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
1344
1345 ; traceTc "tcVect inferred type" $ ppr (varType id')
1346 ; traceTc "tcVect bindings" $ ppr binds
1347
1348 -- add all bindings, including the type variable and dictionary bindings produced by type
1349 -- generalisation to the right-hand side of the vectorisation declaration
1350 ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
1351 ; let [bind'] = bagToList actualBinds
1352 MatchGroup
1353 [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
1354 _ = (fun_matches . unLoc) bind'
1355 rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
1356
1357 -- We return the type-checked 'Id', to propagate the inferred signature
1358 -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
1359 ; return $ HsVect (L loc id') (Just rhsWrapped)
1360 }
1361 -}
1362 tcVect (HsNoVect s name)
1363 = addErrCtxt (vectCtxt name) $
1364 do { var <- wrapLocM tcLookupId name
1365 ; return $ HsNoVect s var
1366 }
1367 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1368 = addErrCtxt (vectCtxt lname) $
1369 do { tycon <- tcLookupLocatedTyCon lname
1370 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1371 || isJust rhs_name -- or we explicitly provide a vectorised type
1372 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1373 )
1374 scalarTyConMustBeNullary
1375
1376 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1377 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1378 }
1379 tcVect (HsVectTypeOut _ _ _)
1380 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1381 tcVect (HsVectClassIn _ lname)
1382 = addErrCtxt (vectCtxt lname) $
1383 do { cls <- tcLookupLocatedClass lname
1384 ; return $ HsVectClassOut cls
1385 }
1386 tcVect (HsVectClassOut _)
1387 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1388 tcVect (HsVectInstIn linstTy)
1389 = addErrCtxt (vectCtxt linstTy) $
1390 do { (cls, tys) <- tcHsVectInst linstTy
1391 ; inst <- tcLookupInstance cls tys
1392 ; return $ HsVectInstOut inst
1393 }
1394 tcVect (HsVectInstOut _)
1395 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1396
1397 vectCtxt :: Outputable thing => thing -> SDoc
1398 vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing
1399
1400 scalarTyConMustBeNullary :: MsgDoc
1401 scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"
1402
1403 {-
1404 Note [SPECIALISE pragmas]
1405 ~~~~~~~~~~~~~~~~~~~~~~~~~
1406 There is no point in a SPECIALISE pragma for a non-overloaded function:
1407 reverse :: [a] -> [a]
1408 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1409
1410 But SPECIALISE INLINE *can* make sense for GADTS:
1411 data Arr e where
1412 ArrInt :: !Int -> ByteArray# -> Arr Int
1413 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1414
1415 (!:) :: Arr e -> Int -> e
1416 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1417 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1418 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1419 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1420
1421 When (!:) is specialised it becomes non-recursive, and can usefully
1422 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1423 for a non-overloaded function.
1424
1425 ************************************************************************
1426 * *
1427 tcMonoBinds
1428 * *
1429 ************************************************************************
1430
1431 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1432 The signatures have been dealt with already.
1433
1434 Note [Pattern bindings]
1435 ~~~~~~~~~~~~~~~~~~~~~~~
1436 The rule for typing pattern bindings is this:
1437
1438 ..sigs..
1439 p = e
1440
1441 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1442 typechecks exactly like
1443
1444 ..sigs..
1445 x = e -- Inferred type
1446 v1 = case x of p -> v1
1447 ..
1448 vn = case x of p -> vn
1449
1450 Note that
1451 (f :: forall a. a -> a) = id
1452 should not typecheck because
1453 case id of { (f :: forall a. a->a) -> f }
1454 will not typecheck.
1455 -}
1456
1457 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1458 -- i.e. the binders are mentioned in their RHSs, and
1459 -- we are not rescued by a type signature
1460 -> TcSigFun -> LetBndrSpec
1461 -> [LHsBind Name]
1462 -> TcM (LHsBinds TcId, [MonoBindInfo])
1463
1464 tcMonoBinds is_rec sig_fn no_gen
1465 [ L b_loc (FunBind { fun_id = L nm_loc name,
1466 fun_matches = matches, bind_fvs = fvs })]
1467 -- Single function binding,
1468 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1469 , Nothing <- sig_fn name -- ...with no type signature
1470 = -- In this very special case we infer the type of the
1471 -- right hand side first (it may have a higher-rank type)
1472 -- and *then* make the monomorphic Id for the LHS
1473 -- e.g. f = \(x::forall a. a->a) -> <body>
1474 -- We want to infer a higher-rank type for f
1475 setSrcSpan b_loc $
1476 do { (rhs_tv, _) <- newOpenReturnTyVar
1477 -- use ReturnTv to allow impredicativity
1478 ; let rhs_ty = mkTyVarTy rhs_tv
1479 ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1480 ; (co_fn, matches')
1481 <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1482 -- We extend the error context even for a non-recursive
1483 -- function so that in type error messages we show the
1484 -- type of the thing whose rhs we are type checking
1485 tcMatchesFun name matches rhs_ty
1486
1487 ; return (unitBag $ L b_loc $
1488 FunBind { fun_id = L nm_loc mono_id,
1489 fun_matches = matches', bind_fvs = fvs,
1490 fun_co_fn = co_fn, fun_tick = [] },
1491 [MBI { mbi_poly_name = name
1492 , mbi_sig = Nothing
1493 , mbi_mono_id = mono_id
1494 , mbi_orig = matchesCtOrigin matches }]) }
1495
1496 tcMonoBinds _ sig_fn no_gen binds
1497 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1498
1499 -- Bring the monomorphic Ids, into scope for the RHSs
1500 ; let mono_info = getMonoBindInfo tc_binds
1501 rhs_id_env = [(name, mono_id) | MBI { mbi_poly_name = name
1502 , mbi_sig = mb_sig
1503 , mbi_mono_id = mono_id }
1504 <- mono_info
1505 , case mb_sig of
1506 Just sig -> isPartialSig sig
1507 Nothing -> True ]
1508 -- A monomorphic binding for each term variable that lacks
1509 -- a type sig. (Ones with a sig are already in scope.)
1510
1511 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1512 | (n,id) <- rhs_id_env]
1513 ; (binds', mono_infos') <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1514 mapAndUnzipM (wrapLocFstM tcRhs) tc_binds
1515 ; return (listToBag binds', concat mono_infos') }
1516
1517 ------------------------
1518 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1519 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1520 -- if there's a signature for it, use the instantiated signature type
1521 -- otherwise invent a type variable
1522 -- You see that quite directly in the FunBind case.
1523 --
1524 -- But there's a complication for pattern bindings:
1525 -- data T = MkT (forall a. a->a)
1526 -- MkT f = e
1527 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1528 -- but we want to get (f::forall a. a->a) as the RHS environment.
1529 -- The simplest way to do this is to typecheck the pattern, and then look up the
1530 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1531 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1532
1533 data TcMonoBind -- Half completed; LHS done, RHS not done
1534 = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
1535 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1536
1537 data MonoBindInfo = MBI { mbi_poly_name :: Name
1538 , mbi_sig :: Maybe TcIdSigInfo
1539 , mbi_mono_id :: TcId
1540 , mbi_orig :: CtOrigin }
1541 -- origin associated with RHS
1542
1543 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1544 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1545 | Just (TcIdSig sig) <- sig_fn name
1546 , TISI { sig_tau = tau } <- sig
1547 = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1548 , ppr name )
1549 -- { f :: ty; f x = e } is always done via CheckGen (full signature)
1550 -- or InferGen (partial signature)
1551 -- see Note [Partial type signatures and generalisation]
1552 -- Both InferGen and CheckGen gives rise to LetLclBndr
1553 do { mono_name <- newLocalName name
1554 ; let mono_id = mkLocalIdOrCoVar mono_name tau
1555 ; return (TcFunBind (MBI { mbi_poly_name = name
1556 , mbi_sig = Just sig
1557 , mbi_mono_id = mono_id
1558 , mbi_orig =
1559 Shouldn'tHappenOrigin "FunBind sig" })
1560 nm_loc matches) }
1561
1562 | otherwise
1563 = do { mono_ty <- newOpenFlexiTyVarTy
1564 ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1565 ; return (TcFunBind (MBI { mbi_poly_name = name
1566 , mbi_sig = Nothing
1567 , mbi_mono_id = mono_id
1568 , mbi_orig =
1569 Shouldn'tHappenOrigin "FunBind nosig" })
1570 nm_loc matches) }
1571
1572 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1573 = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1574 mapM lookup_info (collectPatBinders pat)
1575
1576 -- After typechecking the pattern, look up the binder
1577 -- names, which the pattern has brought into scope.
1578 lookup_info :: Name -> TcM MonoBindInfo
1579 lookup_info name
1580 = do { mono_id <- tcLookupId name
1581 ; let mb_sig = case sig_fn name of
1582 Just (TcIdSig sig) -> Just sig
1583 _ -> Nothing
1584 ; return (MBI { mbi_poly_name = name
1585 , mbi_sig = mb_sig
1586 , mbi_mono_id = mono_id
1587 , mbi_orig =
1588 Shouldn'tHappenOrigin "PatBind" }) }
1589
1590 ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1591 tcInfer tc_pat
1592
1593 ; return (TcPatBind infos pat' grhss pat_ty) }
1594
1595 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1596 -- AbsBind, VarBind impossible
1597
1598 -------------------
1599 tcRhs :: TcMonoBind -> TcM (HsBind TcId, [MonoBindInfo]) -- fills in the mbi_orig
1600 tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
1601 loc matches)
1602 = tcExtendIdBinderStackForRhs [info] $
1603 tcExtendTyVarEnvForRhs mb_sig $
1604 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1605 ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
1606 matches (idType mono_id)
1607 ; return ( FunBind { fun_id = L loc mono_id
1608 , fun_matches = matches'
1609 , fun_co_fn = co_fn
1610 , bind_fvs = placeHolderNamesTc
1611 , fun_tick = [] }
1612 , [info { mbi_orig = matchesCtOrigin matches }] ) }
1613
1614 -- TODO: emit Hole Constraints for wildcards
1615 tcRhs (TcPatBind infos pat' grhss pat_ty)
1616 = -- When we are doing pattern bindings we *don't* bring any scoped
1617 -- type variables into scope unlike function bindings
1618 -- Wny not? They are not completely rigid.
1619 -- That's why we have the special case for a single FunBind in tcMonoBinds
1620 tcExtendIdBinderStackForRhs infos $
1621 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1622 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1623 tcGRHSsPat grhss pat_ty
1624 ; let orig = grhssCtOrigin grhss
1625 infos' = [ info { mbi_orig = orig } | info <- infos ]
1626 ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
1627 , pat_rhs_ty = pat_ty
1628 , bind_fvs = placeHolderNamesTc
1629 , pat_ticks = ([],[]) }
1630 , infos' ) }
1631
1632 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInfo -> TcM a -> TcM a
1633 tcExtendTyVarEnvForRhs Nothing thing_inside
1634 = thing_inside
1635 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1636 = tcExtendTyVarEnvFromSig sig thing_inside
1637
1638 tcExtendTyVarEnvFromSig :: TcIdSigInfo -> TcM a -> TcM a
1639 tcExtendTyVarEnvFromSig sig thing_inside
1640 | TISI { sig_bndr = s_bndr, sig_skols = skol_prs, sig_ctxt = ctxt } <- sig
1641 = tcExtendTyVarEnv2 skol_prs $
1642 case s_bndr of
1643 CompleteSig {} -> thing_inside
1644 PartialSig { sig_wcs = wc_prs } -- Extend the env ad emit the holes
1645 -> tcExtendTyVarEnv2 wc_prs $
1646 do { addErrCtxt (typeSigCtxt ctxt s_bndr) $
1647 emitWildCardHoleConstraints wc_prs
1648 ; thing_inside }
1649
1650 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1651 -- Extend the TcIdBinderStack for the RHS of the binding, with
1652 -- the monomorphic Id. That way, if we have, say
1653 -- f = \x -> blah
1654 -- and something goes wrong in 'blah', we get a "relevant binding"
1655 -- looking like f :: alpha -> beta
1656 -- This applies if 'f' has a type signature too:
1657 -- f :: forall a. [a] -> [a]
1658 -- f x = True
1659 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1660 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1661 -- would not be reported as relevant, because its type is closed
1662 tcExtendIdBinderStackForRhs infos thing_inside
1663 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
1664 | MBI { mbi_mono_id = mono_id } <- infos ]
1665 thing_inside
1666 -- NotTopLevel: it's a monomorphic binding
1667
1668 ---------------------
1669 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1670 getMonoBindInfo tc_binds
1671 = foldr (get_info . unLoc) [] tc_binds
1672 where
1673 get_info (TcFunBind info _ _) rest = info : rest
1674 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1675
1676 {-
1677 ************************************************************************
1678 * *
1679 Signatures
1680 * *
1681 ************************************************************************
1682
1683 Type signatures are tricky. See Note [Signature skolems] in TcType
1684
1685 @tcSigs@ checks the signatures for validity, and returns a list of
1686 {\em freshly-instantiated} signatures. That is, the types are already
1687 split up, and have fresh type variables installed. All non-type-signature
1688 "RenamedSigs" are ignored.
1689
1690 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1691 the variable's type, and after that checked to see whether they've
1692 been instantiated.
1693
1694 Note [Scoped tyvars]
1695 ~~~~~~~~~~~~~~~~~~~~
1696 The -XScopedTypeVariables flag brings lexically-scoped type variables
1697 into scope for any explicitly forall-quantified type variables:
1698 f :: forall a. a -> a
1699 f x = e
1700 Then 'a' is in scope inside 'e'.
1701
1702 However, we do *not* support this
1703 - For pattern bindings e.g
1704 f :: forall a. a->a
1705 (f,g) = e
1706
1707 Note [Signature skolems]
1708 ~~~~~~~~~~~~~~~~~~~~~~~~
1709 When instantiating a type signature, we do so with either skolems or
1710 SigTv meta-type variables depending on the use_skols boolean. This
1711 variable is set True when we are typechecking a single function
1712 binding; and False for pattern bindings and a group of several
1713 function bindings.
1714
1715 Reason: in the latter cases, the "skolems" can be unified together,
1716 so they aren't properly rigid in the type-refinement sense.
1717 NB: unless we are doing H98, each function with a sig will be done
1718 separately, even if it's mutually recursive, so use_skols will be True
1719
1720
1721 Note [Only scoped tyvars are in the TyVarEnv]
1722 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1723 We are careful to keep only the *lexically scoped* type variables in
1724 the type environment. Why? After all, the renamer has ensured
1725 that only legal occurrences occur, so we could put all type variables
1726 into the type env.
1727
1728 But we want to check that two distinct lexically scoped type variables
1729 do not map to the same internal type variable. So we need to know which
1730 the lexically-scoped ones are... and at the moment we do that by putting
1731 only the lexically scoped ones into the environment.
1732
1733 Note [Instantiate sig with fresh variables]
1734 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1735 It's vital to instantiate a type signature with fresh variables.
1736 For example:
1737 type T = forall a. [a] -> [a]
1738 f :: T;
1739 f = g where { g :: T; g = <rhs> }
1740
1741 We must not use the same 'a' from the defn of T at both places!!
1742 (Instantiation is only necessary because of type synonyms. Otherwise,
1743 it's all cool; each signature has distinct type variables from the renamer.)
1744
1745 Note [Fail eagerly on bad signatures]
1746 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1747 If a type signaure is wrong, fail immediately:
1748
1749 * the type sigs may bind type variables, so proceeding without them
1750 can lead to a cascade of errors
1751
1752 * the type signature might be ambiguous, in which case checking
1753 the code against the signature will give a very similar error
1754 to the ambiguity error.
1755
1756 ToDo: this means we fall over if any type sig
1757 is wrong (eg at the top level of the module),
1758 which is over-conservative
1759 -}
1760
1761 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
1762 tcTySigs hs_sigs
1763 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
1764 do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
1765 ; let ty_sigs = concat ty_sigs_s
1766 poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
1767 -- The returned [TcId] are the ones for which we have
1768 -- a complete type signature.
1769 -- See Note [Complete and partial type signatures]
1770 env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]
1771 ; return (poly_ids, lookupNameEnv env) }
1772
1773 tcTySig :: LSig Name -> TcM [TcSigInfo]
1774 tcTySig (L _ (IdSig id))
1775 = do { sig <- instTcTySigFromId id
1776 ; return [TcIdSig sig] }
1777
1778 tcTySig (L loc (TypeSig names sig_ty))
1779 = setSrcSpan loc $
1780 do { sigs <- sequence [ tcUserTypeSig sig_ty (Just name)
1781 | L _ name <- names ]
1782 ; return (map TcIdSig sigs) }
1783
1784 tcTySig (L loc (PatSynSig (L _ name) sig_ty))
1785 = setSrcSpan loc $
1786 do { tpsi <- tcPatSynSig name sig_ty
1787 ; return [TcPatSynSig tpsi] }
1788
1789 tcTySig _ = return []
1790
1791 isCompleteHsSig :: LHsSigWcType Name -> Bool
1792 -- ^ If there are no wildcards, return a LHsSigType
1793 isCompleteHsSig sig_ty
1794 | HsWC { hswc_wcs = wcs, hswc_ctx = extra } <- hsib_body sig_ty
1795 , null wcs
1796 , Nothing <- extra
1797 = True
1798 | otherwise
1799 = False
1800
1801 tcUserTypeSig :: LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo
1802 -- Just n => Function type signatre name :: type
1803 -- Nothing => Expression type signature <expr> :: type
1804 tcUserTypeSig hs_sig_ty mb_name
1805 | isCompleteHsSig hs_sig_ty
1806 = pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
1807 -- so that they can be unified under the forall
1808 do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
1809 ; (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1810 ; loc <- getSrcSpanM
1811 ; return $
1812 TISI { sig_bndr = CompleteSig (mkLocalId name sigma_ty)
1813 , sig_skols = findScopedTyVars sigma_ty inst_tvs
1814 , sig_theta = theta
1815 , sig_tau = tau
1816 , sig_ctxt = ctxt_T
1817 , sig_loc = loc } }
1818
1819 -- Partial sig with wildcards
1820 | HsIB { hsib_vars = vars, hsib_body = wc_ty } <- hs_sig_ty
1821 , HsWC { hswc_wcs = wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty
1822 , (hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
1823 = do { (vars1, (wcs, tvs2, theta, tau))
1824 <- pushTcLevelM_ $
1825 -- When instantiating the signature, do so "one level in"
1826 -- so that they can be unified under the forall
1827 tcImplicitTKBndrs vars $
1828 tcWildCardBinders wcs $ \ wcs ->
1829 tcExplicitTKBndrs hs_tvs $ \ tvs2 ->
1830 do { -- Instantiate the type-class context; but if there
1831 -- is an extra-constraints wildcard, just discard it here
1832 traceTc "tcPartial" (ppr name $$ ppr vars $$ ppr wcs)
1833 ; theta <- mapM tcLHsPredType $
1834 case extra of
1835 Nothing -> hs_ctxt
1836 Just _ -> dropTail 1 hs_ctxt
1837
1838 ; tau <- tcHsOpenType hs_tau
1839
1840 -- zonking is necessary to establish type representation
1841 -- invariants
1842 ; theta <- zonkTcTypes theta
1843 ; tau <- zonkTcType tau
1844
1845 -- Check for validity (eg rankN etc)
1846 -- The ambiguity check will happen (from checkValidType),
1847 -- but unnecessarily; it will always succeed because there
1848 -- is no quantification
1849 ; checkValidType ctxt_F (mkPhiTy theta tau)
1850 -- NB: Do this in the context of the pushTcLevel so that
1851 -- the TcLevel invariant is respected
1852
1853 ; let bound_tvs
1854 = unionVarSets [ allBoundVariabless theta
1855 , allBoundVariables tau
1856 , mkVarSet (map snd wcs) ]
1857 ; return ((wcs, tvs2, theta, tau), bound_tvs) }
1858
1859 ; loc <- getSrcSpanM
1860 ; return $
1861 TISI { sig_bndr = PartialSig { sig_name = name, sig_hs_ty = hs_ty
1862 , sig_cts = extra, sig_wcs = wcs }
1863 , sig_skols = [ (tyVarName tv, tv) | tv <- vars1 ++ tvs2 ]
1864 , sig_theta = theta
1865 , sig_tau = tau
1866 , sig_ctxt = ctxt_F
1867 , sig_loc = loc } }
1868 where
1869 name = case mb_name of
1870 Just n -> n
1871 Nothing -> mkUnboundName (mkVarOcc "<expression>")
1872 ctxt_F = case mb_name of
1873 Just n -> FunSigCtxt n False
1874 Nothing -> ExprSigCtxt
1875 ctxt_T = case mb_name of
1876 Just n -> FunSigCtxt n True
1877 Nothing -> ExprSigCtxt
1878
1879 instTcTySigFromId :: Id -> TcM TcIdSigInfo
1880 -- Used for instance methods and record selectors
1881 instTcTySigFromId id
1882 = do { let name = idName id
1883 loc = getSrcSpan name
1884 ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
1885 (idType id)
1886 ; return $ TISI { sig_bndr = CompleteSig id
1887 , sig_skols = [(tyVarName tv, tv) | tv <- tvs]
1888 -- These are freshly instantiated, so although
1889 -- we put them in the type envt, doing so has
1890 -- no effect
1891 , sig_theta = theta
1892 , sig_tau = tau
1893 , sig_ctxt = FunSigCtxt name False
1894 -- False: do not report redundant constraints
1895 -- The user has no control over the signature!
1896 , sig_loc = loc } }
1897
1898 instTcTySig :: UserTypeCtxt
1899 -> LHsSigType Name -- Used to get the scoped type variables
1900 -> TcType
1901 -> Name -- Name of the function
1902 -> TcM TcIdSigInfo
1903 instTcTySig ctxt hs_ty sigma_ty name
1904 = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1905 ; return (TISI { sig_bndr = CompleteSig (mkLocalIdOrCoVar name sigma_ty)
1906 , sig_skols = findScopedTyVars sigma_ty inst_tvs
1907 , sig_theta = theta
1908 , sig_tau = tau
1909 , sig_ctxt = ctxt
1910 , sig_loc = getLoc (hsSigType hs_ty)
1911 -- SrcSpan from the signature
1912 }) }
1913
1914 -------------------------------
1915 data GeneralisationPlan
1916 = NoGen -- No generalisation, no AbsBinds
1917
1918 | InferGen -- Implicit generalisation; there is an AbsBinds
1919 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1920
1921 | CheckGen (LHsBind Name) TcIdSigInfo
1922 -- One binding with a signature
1923 -- Explicit generalisation; there is an AbsBindsSig
1924
1925 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1926 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1927
1928 instance Outputable GeneralisationPlan where
1929 ppr NoGen = text "NoGen"
1930 ppr (InferGen b) = text "InferGen" <+> ppr b
1931 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1932
1933 decideGeneralisationPlan
1934 :: DynFlags -> TcTypeEnv -> [Name]
1935 -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1936 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1937 | unlifted_pat_binds = NoGen
1938 | Just bind_sig <- one_funbind_with_sig = sig_plan bind_sig
1939 | mono_local_binds = NoGen
1940 | otherwise = InferGen mono_restriction
1941 where
1942 bndr_set = mkNameSet bndr_names
1943 binds = map unLoc lbinds
1944
1945 sig_plan :: (LHsBind Name, TcIdSigInfo) -> GeneralisationPlan
1946 -- See Note [Partial type signatures and generalisation]
1947 -- We use InferGen False to say "do inference, but do not apply
1948 -- the MR". It's stupid to apply the MR when we are given a
1949 -- signature! C.f Trac #11016, function f2
1950 sig_plan (lbind, sig@(TISI { sig_bndr = s_bndr, sig_theta = theta }))
1951 = case s_bndr of
1952 CompleteSig {} -> CheckGen lbind sig
1953 PartialSig { sig_cts = extra_constraints }
1954 | Nothing <- extra_constraints
1955 , [] <- theta
1956 -> InferGen True -- No signature constraints: apply the MR
1957 | otherwise
1958 -> InferGen False -- Don't apply the MR
1959
1960 unlifted_pat_binds = any isUnliftedHsBind binds
1961 -- Unlifted patterns (unboxed tuple) must not
1962 -- be polymorphic, because we are going to force them
1963 -- See Trac #4498, #8762
1964
1965 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1966 && any restricted binds
1967
1968 is_closed_ns :: NameSet -> Bool -> Bool
1969 is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1970 -- ns are the Names referred to from the RHS of this bind
1971
1972 is_closed_id :: Name -> Bool
1973 -- See Note [Bindings with closed types] in TcRnTypes
1974 is_closed_id name
1975 | name `elemNameSet` bndr_set
1976 = True -- Ignore binders in this groups, of course
1977 | Just thing <- lookupNameEnv type_env name
1978 = case thing of
1979 ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
1980 ATyVar {} -> False -- In-scope type variables
1981 AGlobal {} -> True -- are not closed!
1982 _ -> pprPanic "is_closed_id" (ppr name)
1983 | otherwise
1984 = WARN( isInternalName name, ppr name ) True
1985 -- The free-var set for a top level binding mentions
1986 -- imported things too, so that we can report unused imports
1987 -- These won't be in the local type env.
1988 -- Ditto class method etc from the current module
1989
1990 mono_local_binds = xopt LangExt.MonoLocalBinds dflags
1991 && not closed_flag
1992
1993 closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1994
1995 no_sig n = noCompleteSig (sig_fn n)
1996
1997 -- With OutsideIn, all nested bindings are monomorphic
1998 -- except a single function binding with a signature
1999 one_funbind_with_sig
2000 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
2001 , Just (TcIdSig sig) <- sig_fn (unLoc v)
2002 = Just (lbind, sig)
2003 | otherwise
2004 = Nothing
2005
2006 -- The Haskell 98 monomorphism restriction
2007 restricted (PatBind {}) = True
2008 restricted (VarBind { var_id = v }) = no_sig v
2009 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
2010 && no_sig (unLoc v)
2011 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
2012 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
2013 restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"
2014
2015 restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
2016 restricted_match _ = False
2017 -- No args => like a pattern binding
2018 -- Some args => a function binding
2019
2020 -------------------
2021 checkStrictBinds :: TopLevelFlag -> RecFlag
2022 -> [LHsBind Name]
2023 -> LHsBinds TcId -> [Id]
2024 -> TcM ()
2025 -- Check that non-overloaded unlifted bindings are
2026 -- a) non-recursive,
2027 -- b) not top level,
2028 -- c) not a multiple-binding group (more or less implied by (a))
2029
2030 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
2031 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
2032 = do { check (isNotTopLevel top_lvl)
2033 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
2034 ; check (isNonRec rec_group)
2035 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
2036
2037 ; check (all is_monomorphic (bagToList tc_binds))
2038 (polyBindErr orig_binds)
2039 -- data Ptr a = Ptr Addr#
2040 -- f x = let p@(Ptr y) = ... in ...
2041 -- Here the binding for 'p' is polymorphic, but does
2042 -- not mix with an unlifted binding for 'y'. You should
2043 -- use a bang pattern. Trac #6078.
2044
2045 ; check (isSingleton orig_binds)
2046 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
2047
2048 -- Complain about a binding that looks lazy
2049 -- e.g. let I# y = x in ...
2050 -- Remember, in checkStrictBinds we are going to do strict
2051 -- matching, so (for software engineering reasons) we insist
2052 -- that the strictness is manifest on each binding
2053 -- However, lone (unboxed) variables are ok
2054 ; check (not any_pat_looks_lazy)
2055 (unliftedMustBeBang orig_binds) }
2056 | otherwise
2057 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
2058 return ()
2059 where
2060 any_unlifted_bndr = any is_unlifted poly_ids
2061 any_strict_pat = any (isUnliftedHsBind . unLoc) orig_binds
2062 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
2063
2064 is_unlifted id = case tcSplitSigmaTy (idType id) of
2065 (_, _, rho) -> isUnLiftedType rho
2066 -- For the is_unlifted check, we need to look inside polymorphism
2067 -- and overloading. E.g. x = (# 1, True #)
2068 -- would get type forall a. Num a => (# a, Bool #)
2069 -- and we want to reject that. See Trac #9140
2070
2071 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
2072 = null tvs && null evs
2073 is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }))
2074 = null tvs && null evs
2075 is_monomorphic _ = True
2076
2077 check :: Bool -> MsgDoc -> TcM ()
2078 -- Just like checkTc, but with a special case for module GHC.Prim:
2079 -- see Note [Compiling GHC.Prim]
2080 check True _ = return ()
2081 check False err = do { mod <- getModule
2082 ; checkTc (mod == gHC_PRIM) err }
2083
2084 unliftedMustBeBang :: [LHsBind Name] -> SDoc
2085 unliftedMustBeBang binds
2086 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
2087 2 (vcat (map ppr binds))
2088
2089 polyBindErr :: [LHsBind Name] -> SDoc
2090 polyBindErr binds
2091 = hang (text "You can't mix polymorphic and unlifted bindings")
2092 2 (vcat [vcat (map ppr binds),
2093 text "Probable fix: add a type signature"])
2094
2095 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
2096 strictBindErr flavour any_unlifted_bndr binds
2097 = hang (text flavour <+> msg <+> text "aren't allowed:")
2098 2 (vcat (map ppr binds))
2099 where
2100 msg | any_unlifted_bndr = text "bindings for unlifted types"
2101 | otherwise = text "bang-pattern or unboxed-tuple bindings"
2102
2103
2104 {- Note [Compiling GHC.Prim]
2105 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2106 Module GHC.Prim has no source code: it is the host module for
2107 primitive, built-in functions and types. However, for Haddock-ing
2108 purposes we generate (via utils/genprimopcode) a fake source file
2109 GHC/Prim.hs, and give it to Haddock, so that it can generate
2110 documentation. It contains definitions like
2111 nullAddr# :: NullAddr#
2112 which would normally be rejected as a top-level unlifted binding. But
2113 we don't want to complain, because we are only "compiling" this fake
2114 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
2115 in checkStrictBinds.
2116
2117 (We only make the test if things look wrong, so there is no cost in
2118 the common case.) -}
2119
2120
2121 {- *********************************************************************
2122 * *
2123 Error contexts and messages
2124 * *
2125 ********************************************************************* -}
2126
2127 -- This one is called on LHS, when pat and grhss are both Name
2128 -- and on RHS, when pat is TcId and grhss is still Name
2129 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
2130 patMonoBindsCtxt pat grhss
2131 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
2132
2133 typeSigCtxt :: UserTypeCtxt -> TcIdSigBndr -> SDoc
2134 typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty })
2135 = pprSigCtxt ctxt empty (ppr hs_ty)
2136 typeSigCtxt ctxt (CompleteSig id)
2137 = pprSigCtxt ctxt empty (ppr (idType id))
2138
2139 instErrCtxt :: TcId -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
2140 instErrCtxt id ty env
2141 = do { let (env', ty') = tidyOpenType env ty
2142 ; return (env', hang (text "When instantiating" <+> quotes (ppr id) <>
2143 text ", initially inferred to have" $$
2144 text "this overly-general type:")
2145 2 (ppr ty') $$
2146 extra) }
2147 where
2148 extra = sdocWithDynFlags $ \dflags ->
2149 ppWhen (xopt LangExt.MonomorphismRestriction dflags) $
2150 text "NB: This instantiation can be caused by the" <+>
2151 text "monomorphism restriction."