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