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