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