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