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