s/Invisible/Inferred/g s/Visible/Required/g
[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 tcVectDecls, addTypecheckedBinds,
14 chooseInferredQuantifiers,
15 badBootDeclErr ) where
16
17 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
18 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
19 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
20 , tcPatSynBuilderBind )
21 import DynFlags
22 import HsSyn
23 import HscTypes( isHsBootOrSig )
24 import TcSigs
25 import TcRnMonad
26 import TcEnv
27 import TcUnify
28 import TcSimplify
29 import TcEvidence
30 import TcHsType
31 import TcPat
32 import TcMType
33 import Inst( deeplyInstantiate )
34 import FamInstEnv( normaliseType )
35 import FamInst( tcGetFamInstEnvs )
36 import TyCon
37 import TcType
38 import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder )
39 import TysPrim
40 import TysWiredIn( cTupleTyConName )
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 PrelNames( gHC_PRIM, ipClassName )
59 import TcValidity (checkValidType)
60 import UniqFM
61 import qualified GHC.LanguageExtensions as LangExt
62
63 import Control.Monad
64
65 #include "HsVersions.h"
66
67 {- *********************************************************************
68 * *
69 A useful helper function
70 * *
71 ********************************************************************* -}
72
73 addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv
74 addTypecheckedBinds tcg_env binds
75 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
76 -- Do not add the code for record-selector bindings
77 -- when compiling hs-boot files
78 | otherwise = tcg_env { tcg_binds = foldr unionBags
79 (tcg_binds tcg_env)
80 binds }
81
82 {-
83 ************************************************************************
84 * *
85 \subsection{Type-checking bindings}
86 * *
87 ************************************************************************
88
89 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
90 it needs to know something about the {\em usage} of the things bound,
91 so that it can create specialisations of them. So @tcBindsAndThen@
92 takes a function which, given an extended environment, E, typechecks
93 the scope of the bindings returning a typechecked thing and (most
94 important) an LIE. It is this LIE which is then used as the basis for
95 specialising the things bound.
96
97 @tcBindsAndThen@ also takes a "combiner" which glues together the
98 bindings and the "thing" to make a new "thing".
99
100 The real work is done by @tcBindWithSigsAndThen@.
101
102 Recursive and non-recursive binds are handled in essentially the same
103 way: because of uniques there are no scoping issues left. The only
104 difference is that non-recursive bindings can bind primitive values.
105
106 Even for non-recursive binding groups we add typings for each binder
107 to the LVE for the following reason. When each individual binding is
108 checked the type of its LHS is unified with that of its RHS; and
109 type-checking the LHS of course requires that the binder is in scope.
110
111 At the top-level the LIE is sure to contain nothing but constant
112 dictionaries, which we resolve at the module level.
113
114 Note [Polymorphic recursion]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 The game plan for polymorphic recursion in the code above is
117
118 * Bind any variable for which we have a type signature
119 to an Id with a polymorphic type. Then when type-checking
120 the RHSs we'll make a full polymorphic call.
121
122 This fine, but if you aren't a bit careful you end up with a horrendous
123 amount of partial application and (worse) a huge space leak. For example:
124
125 f :: Eq a => [a] -> [a]
126 f xs = ...f...
127
128 If we don't take care, after typechecking we get
129
130 f = /\a -> \d::Eq a -> let f' = f a d
131 in
132 \ys:[a] -> ...f'...
133
134 Notice the the stupid construction of (f a d), which is of course
135 identical to the function we're executing. In this case, the
136 polymorphic recursion isn't being used (but that's a very common case).
137 This can lead to a massive space leak, from the following top-level defn
138 (post-typechecking)
139
140 ff :: [Int] -> [Int]
141 ff = f Int dEqInt
142
143 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
144 f' is another thunk which evaluates to the same thing... and you end
145 up with a chain of identical values all hung onto by the CAF ff.
146
147 ff = f Int dEqInt
148
149 = let f' = f Int dEqInt in \ys. ...f'...
150
151 = let f' = let f' = f Int dEqInt in \ys. ...f'...
152 in \ys. ...f'...
153
154 Etc.
155
156 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
157 which would make the space leak go away in this case
158
159 Solution: when typechecking the RHSs we always have in hand the
160 *monomorphic* Ids for each binding. So we just need to make sure that
161 if (Method f a d) shows up in the constraints emerging from (...f...)
162 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
163 to the "givens" when simplifying constraints. That's what the "lies_avail"
164 is doing.
165
166 Then we get
167
168 f = /\a -> \d::Eq a -> letrec
169 fm = \ys:[a] -> ...fm...
170 in
171 fm
172 -}
173
174 tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv)
175 -- The TcGblEnv contains the new tcg_binds and tcg_spects
176 -- The TcLclEnv has an extended type envt for the new bindings
177 tcTopBinds binds sigs
178 = do { -- Pattern synonym bindings populate the global environment
179 (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
180 do { gbl <- getGblEnv
181 ; lcl <- getLclEnv
182 ; return (gbl, lcl) }
183 ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
184
185 ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env }
186 `addTypecheckedBinds` map snd binds' }
187
188 ; return (tcg_env', tcl_env) }
189 -- The top level bindings are flattened into a giant
190 -- implicitly-mutually-recursive LHsBinds
191
192 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
193 tcRecSelBinds (ValBindsOut binds sigs)
194 = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
195 do { (rec_sel_binds, tcg_env) <- discardWarnings $
196 tcValBinds TopLevel binds sigs getGblEnv
197 ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
198 ; return tcg_env' }
199 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
200
201 tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id]
202 -- A hs-boot file has only one BindGroup, and it only has type
203 -- signatures in it. The renamer checked all this
204 tcHsBootSigs binds sigs
205 = do { checkTc (null binds) badBootDeclErr
206 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
207 where
208 tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames
209 where
210 f (L _ name)
211 = do { sigma_ty <- solveEqualities $
212 tcHsSigWcType (FunSigCtxt name False) hs_ty
213 ; return (mkVanillaGlobal name sigma_ty) }
214 -- Notice that we make GlobalIds, not LocalIds
215 tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
216
217 badBootDeclErr :: MsgDoc
218 badBootDeclErr = text "Illegal declarations in an hs-boot file"
219
220 ------------------------
221 tcLocalBinds :: HsLocalBinds Name -> TcM thing
222 -> TcM (HsLocalBinds TcId, thing)
223
224 tcLocalBinds EmptyLocalBinds thing_inside
225 = do { thing <- thing_inside
226 ; return (EmptyLocalBinds, thing) }
227
228 tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
229 = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
230 ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
231 tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
232
233 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
234 = do { ipClass <- tcLookupClass ipClassName
235 ; (given_ips, ip_binds') <-
236 mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
237
238 -- If the binding binds ?x = E, we must now
239 -- discharge any ?x constraints in expr_lie
240 -- See Note [Implicit parameter untouchables]
241 ; (ev_binds, result) <- checkConstraints (IPSkol ips)
242 [] given_ips thing_inside
243
244 ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
245 where
246 ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]
247
248 -- I wonder if we should do these one at at time
249 -- Consider ?x = 4
250 -- ?y = ?x + 1
251 tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)
252 = do { ty <- newOpenFlexiTyVarTy
253 ; let p = mkStrLitTy $ hsIPNameFS ip
254 ; ip_id <- newDict ipClass [ p, ty ]
255 ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
256 ; let d = toDict ipClass p ty `fmap` expr'
257 ; return (ip_id, (IPBind (Right ip_id) d)) }
258 tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
259
260 -- Coerces a `t` into a dictionry for `IP "x" t`.
261 -- co : t -> IP "x" t
262 toDict ipClass x ty = HsWrap $ mkWpCastR $
263 wrapIP $ mkClassPred ipClass [x,ty]
264
265 {- Note [Implicit parameter untouchables]
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 We add the type variables in the types of the implicit parameters
268 as untouchables, not so much because we really must not unify them,
269 but rather because we otherwise end up with constraints like this
270 Num alpha, Implic { wanted = alpha ~ Int }
271 The constraint solver solves alpha~Int by unification, but then
272 doesn't float that solved constraint out (it's not an unsolved
273 wanted). Result disaster: the (Num alpha) is again solved, this
274 time by defaulting. No no no.
275
276 However [Oct 10] this is all handled automatically by the
277 untouchable-range idea.
278
279 Note [Inlining and hs-boot files]
280 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
281 Consider this example (Trac #10083):
282
283 ---------- RSR.hs-boot ------------
284 module RSR where
285 data RSR
286 eqRSR :: RSR -> RSR -> Bool
287
288 ---------- SR.hs ------------
289 module SR where
290 import {-# SOURCE #-} RSR
291 data SR = MkSR RSR
292 eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
293
294 ---------- RSR.hs ------------
295 module RSR where
296 import SR
297 data RSR = MkRSR SR -- deriving( Eq )
298 eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
299 foo x y = not (eqRSR x y)
300
301 When compiling RSR we get this code
302
303 RSR.eqRSR :: RSR -> RSR -> Bool
304 RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->
305 case ds1 of _ { RSR.MkRSR s1 ->
306 case ds2 of _ { RSR.MkRSR s2 ->
307 SR.eqSR s1 s2 }}
308
309 RSR.foo :: RSR -> RSR -> Bool
310 RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)
311
312 Now, when optimising foo:
313 Inline eqRSR (small, non-rec)
314 Inline eqSR (small, non-rec)
315 but the result of inlining eqSR from SR is another call to eqRSR, so
316 everything repeats. Neither eqSR nor eqRSR are (apparently) loop
317 breakers.
318
319 Solution: when compiling RSR, add a NOINLINE pragma to every function
320 exported by the boot-file for RSR (if it exists).
321
322 ALAS: doing so makes the boostrappted GHC itself slower by 8% overall
323 (on Trac #9872a-d, and T1969. So I un-did this change, and
324 parked it for now. Sigh.
325 -}
326
327 tcValBinds :: TopLevelFlag
328 -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
329 -> TcM thing
330 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
331
332 tcValBinds top_lvl binds sigs thing_inside
333 = do { let patsyns = getPatSynBinds binds
334
335 -- Typecheck the signature
336 ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
337 tcTySigs sigs
338
339 ; _self_boot <- tcSelfBootInfo
340 ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
341
342 -- ------- See Note [Inlining and hs-boot files] (change parked) --------
343 -- prag_fn | isTopLevel top_lvl -- See Note [Inlining and hs-boot files]
344 -- , SelfBoot { sb_ids = boot_id_names } <- self_boot
345 -- = foldNameSet add_no_inl prag_fn1 boot_id_names
346 -- | otherwise
347 -- = prag_fn1
348 -- add_no_inl boot_id_name prag_fn
349 -- = extendPragEnv prag_fn (boot_id_name, no_inl_sig boot_id_name)
350 -- no_inl_sig name = L boot_loc (InlineSig (L boot_loc name) neverInlinePragma)
351 -- boot_loc = mkGeneralSrcSpan (fsLit "The hs-boot file for this module")
352
353 -- Extend the envt right away with all the Ids
354 -- declared with complete type signatures
355 -- Do not extend the TcIdBinderStack; instead
356 -- we extend it on a per-rhs basis in tcExtendForRhs
357 ; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $ do
358 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
359 { thing <- thing_inside
360 -- See Note [Pattern synonym builders don't yield dependencies]
361 ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
362 ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
363 ; return (extra_binds, thing) }
364 ; return (binds' ++ extra_binds', thing) }}
365
366 ------------------------
367 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
368 -> [(RecFlag, LHsBinds Name)] -> TcM thing
369 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
370 -- Typecheck a whole lot of value bindings,
371 -- one strongly-connected component at a time
372 -- Here a "strongly connected component" has the strightforward
373 -- meaning of a group of bindings that mention each other,
374 -- ignoring type signatures (that part comes later)
375
376 tcBindGroups _ _ _ [] thing_inside
377 = do { thing <- thing_inside
378 ; return ([], thing) }
379
380 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
381 = do { -- See Note [Closed binder groups]
382 closed <- isClosedBndrGroup $ snd group
383 ; (group', (groups', thing))
384 <- tc_group top_lvl sig_fn prag_fn group closed $
385 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
386 ; return (group' ++ groups', thing) }
387
388 -- Note [Closed binder groups]
389 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
390 --
391 -- A mutually recursive group is "closed" if all of the free variables of
392 -- the bindings are closed. For example
393 --
394 -- > h = \x -> let f = ...g...
395 -- > g = ....f...x...
396 -- > in ...
397 --
398 -- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
399 -- closed.
400 --
401 -- So we need to compute closed-ness on each strongly connected components,
402 -- before we sub-divide it based on what type signatures it has.
403 --
404
405 ------------------------
406 tc_group :: forall thing.
407 TopLevelFlag -> TcSigFun -> TcPragEnv
408 -> (RecFlag, LHsBinds Name) -> IsGroupClosed -> TcM thing
409 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
410
411 -- Typecheck one strongly-connected component of the original program.
412 -- We get a list of groups back, because there may
413 -- be specialisations etc as well
414
415 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
416 -- A single non-recursive binding
417 -- We want to keep non-recursive things non-recursive
418 -- so that we desugar unlifted bindings correctly
419 = do { let bind = case bagToList binds of
420 [bind] -> bind
421 [] -> panic "tc_group: empty list of binds"
422 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
423 ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
424 thing_inside
425 ; return ( [(NonRecursive, bind')], thing) }
426
427 tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
428 = -- To maximise polymorphism, we do a new
429 -- strongly-connected-component analysis, this time omitting
430 -- any references to variables with type signatures.
431 -- (This used to be optional, but isn't now.)
432 -- See Note [Polymorphic recursion] in HsBinds.
433 do { traceTc "tc_group rec" (pprLHsBinds binds)
434 ; when hasPatSyn $ recursivePatSynErr binds
435 ; (binds1, thing) <- go sccs
436 ; return ([(Recursive, binds1)], thing) }
437 -- Rec them all together
438 where
439 hasPatSyn = anyBag (isPatSyn . unLoc) binds
440 isPatSyn PatSynBind{} = True
441 isPatSyn _ = False
442
443 sccs :: [SCC (LHsBind Name)]
444 sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
445
446 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
447 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
448 ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1
449 (go sccs)
450 ; return (binds1 `unionBags` binds2, thing) }
451 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
452
453 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
454 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
455
456 tc_sub_group rec_tc binds =
457 tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds
458
459 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
460 recursivePatSynErr binds
461 = failWithTc $
462 hang (text "Recursive pattern synonym definition with following bindings:")
463 2 (vcat $ map pprLBind . bagToList $ binds)
464 where
465 pprLoc loc = parens (text "defined at" <+> ppr loc)
466 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
467 pprLoc loc
468
469 tc_single :: forall thing.
470 TopLevelFlag -> TcSigFun -> TcPragEnv
471 -> LHsBind Name -> IsGroupClosed -> TcM thing
472 -> TcM (LHsBinds TcId, thing)
473 tc_single _top_lvl sig_fn _prag_fn
474 (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
475 _ thing_inside
476 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
477 ; thing <- setGblEnv tcg_env thing_inside
478 ; return (aux_binds, thing)
479 }
480 where
481 tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)
482 tc_pat_syn_decl = case sig_fn name of
483 Nothing -> tcInferPatSynDecl psb
484 Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
485 Just _ -> panic "tc_single"
486
487 tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
488 = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
489 NonRecursive NonRecursive
490 closed
491 [lbind]
492 ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
493 ; return (binds1, thing) }
494
495 ------------------------
496 type BKey = Int -- Just number off the bindings
497
498 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
499 -- See Note [Polymorphic recursion] in HsBinds.
500 mkEdges sig_fn binds
501 = [ (bind, key, [key | n <- nonDetEltsUFM (bind_fvs (unLoc bind)),
502 Just key <- [lookupNameEnv key_map n], no_sig n ])
503 | (bind, key) <- keyd_binds
504 ]
505 -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
506 -- is still deterministic even if the edges are in nondeterministic order
507 -- as explained in Note [Deterministic SCC] in Digraph.
508 where
509 no_sig :: Name -> Bool
510 no_sig n = noCompleteSig (sig_fn n)
511
512 keyd_binds = bagToList binds `zip` [0::BKey ..]
513
514 key_map :: NameEnv BKey -- Which binding it comes from
515 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
516 , bndr <- collectHsBindBinders bind ]
517
518 ------------------------
519 tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
520 -> RecFlag -- Whether the group is really recursive
521 -> RecFlag -- Whether it's recursive after breaking
522 -- dependencies based on type signatures
523 -> IsGroupClosed -- Whether the group is closed
524 -> [LHsBind Name] -- None are PatSynBind
525 -> TcM (LHsBinds TcId, [TcId])
526
527 -- Typechecks a single bunch of values bindings all together,
528 -- and generalises them. The bunch may be only part of a recursive
529 -- group, because we use type signatures to maximise polymorphism
530 --
531 -- Returns a list because the input may be a single non-recursive binding,
532 -- in which case the dependency order of the resulting bindings is
533 -- important.
534 --
535 -- Knows nothing about the scope of the bindings
536 -- None of the bindings are pattern synonyms
537
538 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
539 = setSrcSpan loc $
540 recoverM (recoveryCode binder_names sig_fn) $ do
541 -- Set up main recover; take advantage of any type sigs
542
543 { traceTc "------------------------------------------------" Outputable.empty
544 ; traceTc "Bindings for {" (ppr binder_names)
545 ; dflags <- getDynFlags
546 ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
547 ; traceTc "Generalisation plan" (ppr plan)
548 ; result@(tc_binds, poly_ids) <- case plan of
549 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
550 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
551 CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
552
553 -- Check whether strict bindings are ok
554 -- These must be non-recursive etc, and are not generalised
555 -- They desugar to a case expression in the end
556 ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
557 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
558 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
559 ])
560
561 ; return result }
562 where
563 binder_names = collectHsBindListBinders bind_list
564 loc = foldr1 combineSrcSpans (map getLoc bind_list)
565 -- The mbinds have been dependency analysed and
566 -- may no longer be adjacent; so find the narrowest
567 -- span that includes them all
568
569 --------------
570 -- If typechecking the binds fails, then return with each
571 -- signature-less binder given type (forall a.a), to minimise
572 -- subsequent error messages
573 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
574 recoveryCode binder_names sig_fn
575 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
576 ; let poly_ids = map mk_dummy binder_names
577 ; return (emptyBag, poly_ids) }
578 where
579 mk_dummy name
580 | Just sig <- sig_fn name
581 , Just poly_id <- completeSigPolyId_maybe sig
582 = poly_id
583 | otherwise
584 = mkLocalId name forall_a_a
585
586 forall_a_a :: TcType
587 forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
588
589 {- *********************************************************************
590 * *
591 tcPolyNoGen
592 * *
593 ********************************************************************* -}
594
595 tcPolyNoGen -- No generalisation whatsoever
596 :: RecFlag -- Whether it's recursive after breaking
597 -- dependencies based on type signatures
598 -> TcPragEnv -> TcSigFun
599 -> [LHsBind Name]
600 -> TcM (LHsBinds TcId, [TcId])
601
602 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
603 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
604 (LetGblBndr prag_fn)
605 bind_list
606 ; mono_ids' <- mapM tc_mono_info mono_infos
607 ; return (binds', mono_ids') }
608 where
609 tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
610 = do { mono_ty' <- zonkTcType (idType mono_id)
611 -- Zonk, mainly to expose unboxed types to checkStrictBinds
612 ; let mono_id' = setIdType mono_id mono_ty'
613 ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)
614 ; return mono_id' }
615 -- NB: tcPrags generates error messages for
616 -- specialisation pragmas for non-overloaded sigs
617 -- Indeed that is why we call it here!
618 -- So we can safely ignore _specs
619
620
621 {- *********************************************************************
622 * *
623 tcPolyCheck
624 * *
625 ********************************************************************* -}
626
627 tcPolyCheck :: TcPragEnv
628 -> TcIdSigInfo -- Must be a complete signature
629 -> LHsBind Name -- Must be a FunBind
630 -> TcM (LHsBinds TcId, [TcId])
631 -- There is just one binding,
632 -- it is a Funbind
633 -- it has a complete type signature,
634 tcPolyCheck prag_fn
635 (CompleteSig { sig_bndr = poly_id
636 , sig_ctxt = ctxt
637 , sig_loc = sig_loc })
638 (L loc (FunBind { fun_id = L nm_loc name
639 , fun_matches = matches }))
640 = setSrcSpan sig_loc $
641 do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
642 ; (tv_prs, theta, tau) <- tcInstType (tcInstSigTyVars sig_loc) poly_id
643 -- See Note [Instantiate sig with fresh variables]
644
645 ; mono_name <- newNameAt (nameOccName name) nm_loc
646 ; ev_vars <- newEvVars theta
647 ; let mono_id = mkLocalId mono_name tau
648 skol_info = SigSkol ctxt (mkPhiTy theta tau)
649 skol_tvs = map snd tv_prs
650
651 ; (ev_binds, (co_fn, matches'))
652 <- checkConstraints skol_info skol_tvs ev_vars $
653 tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
654 tcExtendTyVarEnv2 tv_prs $
655 setSrcSpan loc $
656 tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
657
658 ; let prag_sigs = lookupPragEnv prag_fn name
659 ; spec_prags <- tcSpecPrags poly_id prag_sigs
660 ; poly_id <- addInlinePrags poly_id prag_sigs
661
662 ; let bind' = FunBind { fun_id = L nm_loc mono_id
663 , fun_matches = matches'
664 , fun_co_fn = co_fn
665 , bind_fvs = placeHolderNamesTc
666 , fun_tick = [] }
667
668 abs_bind = L loc $ AbsBindsSig
669 { abs_sig_export = poly_id
670 , abs_tvs = skol_tvs
671 , abs_ev_vars = ev_vars
672 , abs_sig_prags = SpecPrags spec_prags
673 , abs_sig_ev_bind = ev_binds
674 , abs_sig_bind = L loc bind' }
675
676 ; return (unitBag abs_bind, [poly_id]) }
677
678 tcPolyCheck _prag_fn sig bind
679 = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
680
681 {- Note [Instantiate sig with fresh variables]
682 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
683 It's vital to instantiate a type signature with fresh variables.
684 For example:
685 type T = forall a. [a] -> [a]
686 f :: T;
687 f = g where { g :: T; g = <rhs> }
688
689 We must not use the same 'a' from the defn of T at both places!!
690 (Instantiation is only necessary because of type synonyms. Otherwise,
691 it's all cool; each signature has distinct type variables from the renamer.)
692 -}
693
694
695 {- *********************************************************************
696 * *
697 tcPolyInfer
698 * *
699 ********************************************************************* -}
700
701 tcPolyInfer
702 :: RecFlag -- Whether it's recursive after breaking
703 -- dependencies based on type signatures
704 -> TcPragEnv -> TcSigFun
705 -> Bool -- True <=> apply the monomorphism restriction
706 -> [LHsBind Name]
707 -> TcM (LHsBinds TcId, [TcId])
708 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
709 = do { (tclvl, wanted, (binds', mono_infos))
710 <- pushLevelAndCaptureConstraints $
711 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
712
713 ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
714 | info <- mono_infos ]
715 sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
716 infer_mode = if mono then ApplyMR else NoRestrictions
717
718 ; mapM_ (checkOverloadedSig mono) sigs
719
720 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
721 ; (qtvs, givens, ev_binds)
722 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
723
724 ; let inferred_theta = map evVarPred givens
725 ; exports <- checkNoErrs $
726 mapM (mkExport prag_fn qtvs inferred_theta) mono_infos
727
728 ; loc <- getSrcSpanM
729 ; let poly_ids = map abe_poly exports
730 abs_bind = L loc $
731 AbsBinds { abs_tvs = qtvs
732 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
733 , abs_exports = exports, abs_binds = binds' }
734
735 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
736 ; return (unitBag abs_bind, poly_ids) }
737 -- poly_ids are guaranteed zonked by mkExport
738
739 --------------
740 mkExport :: TcPragEnv
741 -> [TyVar] -> TcThetaType -- Both already zonked
742 -> MonoBindInfo
743 -> TcM (ABExport Id)
744 -- Only called for generalisation plan InferGen, not by CheckGen or NoGen
745 --
746 -- mkExport generates exports with
747 -- zonked type variables,
748 -- zonked poly_ids
749 -- The former is just because no further unifications will change
750 -- the quantified type variables, so we can fix their final form
751 -- right now.
752 -- The latter is needed because the poly_ids are used to extend the
753 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
754
755 -- Pre-condition: the qtvs and theta are already zonked
756
757 mkExport prag_fn qtvs theta
758 mono_info@(MBI { mbi_poly_name = poly_name
759 , mbi_sig = mb_sig
760 , mbi_mono_id = mono_id })
761 = do { mono_ty <- zonkTcType (idType mono_id)
762 ; poly_id <- mkInferredPolyId qtvs theta poly_name mb_sig mono_ty
763
764 -- NB: poly_id has a zonked type
765 ; poly_id <- addInlinePrags poly_id prag_sigs
766 ; spec_prags <- tcSpecPrags poly_id prag_sigs
767 -- tcPrags requires a zonked poly_id
768
769 -- See Note [Impedence matching]
770 -- NB: we have already done checkValidType, including an ambiguity check,
771 -- on the type; either when we checked the sig or in mkInferredPolyId
772 ; let poly_ty = idType poly_id
773 sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
774 -- This type is just going into tcSubType,
775 -- so Inferred vs. Specified doesn't matter
776
777 ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility
778 then return idHsWrapper -- Fast path; also avoids complaint when we infer
779 -- an ambiguouse type and have AllowAmbiguousType
780 -- e..g infer x :: forall a. F a -> Int
781 else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
782 tcSubType_NC sig_ctxt sel_poly_ty (mkCheckExpType poly_ty)
783
784 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
785 ; when warn_missing_sigs $
786 localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
787
788 ; return (ABE { abe_wrap = wrap
789 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
790 , abe_poly = poly_id
791 , abe_mono = mono_id
792 , abe_prags = SpecPrags spec_prags}) }
793 where
794 prag_sigs = lookupPragEnv prag_fn poly_name
795 sig_ctxt = InfSigCtxt poly_name
796
797 mkInferredPolyId :: [TyVar] -> TcThetaType
798 -> Name -> Maybe TcIdSigInst -> TcType
799 -> TcM TcId
800 mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty
801 | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
802 , CompleteSig { sig_bndr = poly_id } <- sig
803 = return poly_id
804
805 | otherwise -- Either no type sig or partial type sig
806 = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous
807 -- we don't carry on to the impedence matching, and generate
808 -- a duplicate ambiguity error. There is a similar
809 -- checkNoErrs for complete type signatures too.
810 do { fam_envs <- tcGetFamInstEnvs
811 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
812 -- Unification may not have normalised the type,
813 -- (see Note [Lazy flattening] in TcFlatten) so do it
814 -- here to make it as uncomplicated as possible.
815 -- Example: f :: [F Int] -> Bool
816 -- should be rewritten to f :: [Char] -> Bool, if possible
817 --
818 -- We can discard the coercion _co, because we'll reconstruct
819 -- it in the call to tcSubType below
820
821 ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
822 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
823
824 ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
825
826 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
827 , ppr inferred_poly_ty])
828 ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
829 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
830 -- See Note [Validity of inferred types]
831
832 ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
833
834
835 chooseInferredQuantifiers :: TcThetaType -- inferred
836 -> TcTyVarSet -- tvs free in tau type
837 -> [TcTyVar] -- inferred quantified tvs
838 -> Maybe TcIdSigInst
839 -> TcM ([TyVarBinder], TcThetaType)
840 chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
841 = -- No type signature (partial or complete) for this binder,
842 do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
843 -- Include kind variables! Trac #7916
844 my_theta = pickCapturedPreds free_tvs inferred_theta
845 binders = [ mkTyVarBinder Inferred tv
846 | tv <- qtvs
847 , tv `elemVarSet` free_tvs ]
848 ; return (binders, my_theta) }
849
850 chooseInferredQuantifiers inferred_theta tau_tvs qtvs
851 (Just (TISI { sig_inst_sig = sig -- Always PartialSig
852 , sig_inst_wcx = wcx
853 , sig_inst_theta = annotated_theta
854 , sig_inst_skols = annotated_tvs }))
855 | Nothing <- wcx
856 = do { annotated_theta <- zonkTcTypes annotated_theta
857 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
858 `unionVarSet` tau_tvs)
859 ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs])
860 ; return (mk_binders free_tvs, annotated_theta) }
861
862 | Just wc_var <- wcx
863 = do { annotated_theta <- zonkTcTypes annotated_theta
864 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
865 `unionVarSet` tau_tvs)
866 my_theta = pickCapturedPreds free_tvs inferred_theta
867
868 -- Report the inferred constraints for an extra-constraints wildcard/hole as
869 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
870 -- case, the extra inferred constraints are accepted without complaining.
871 -- NB: inferred_theta already includes all the annotated constraints
872 inferred_diff = [ pred
873 | pred <- my_theta
874 , all (not . (`eqType` pred)) annotated_theta ]
875 ; ctuple <- mk_ctuple inferred_diff
876 ; writeMetaTyVar wc_var ctuple
877 ; traceTc "completeTheta" $
878 vcat [ ppr sig
879 , ppr annotated_theta, ppr inferred_theta
880 , ppr inferred_diff ]
881
882 ; return (mk_binders free_tvs, my_theta) }
883
884 | otherwise -- A complete type signature is dealt with in mkInferredPolyId
885 = pprPanic "chooseInferredQuantifiers" (ppr sig)
886
887 where
888 spec_tv_set = mkVarSet $ map snd annotated_tvs
889 mk_binders free_tvs
890 = [ mkTyVarBinder vis tv
891 | tv <- qtvs
892 , tv `elemVarSet` free_tvs
893 , let vis | tv `elemVarSet` spec_tv_set = Specified
894 | otherwise = Inferred ]
895 -- Pulling from qtvs maintains original order
896
897 mk_ctuple [pred] = return pred
898 mk_ctuple preds = do { tc <- tcLookupTyCon (cTupleTyConName (length preds))
899 ; return (mkTyConApp tc preds) }
900
901 mk_impedence_match_msg :: MonoBindInfo
902 -> TcType -> TcType
903 -> TidyEnv -> TcM (TidyEnv, SDoc)
904 -- This is a rare but rather awkward error messages
905 mk_impedence_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
906 inf_ty sig_ty tidy_env
907 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
908 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
909 ; let msg = vcat [ text "When checking that the inferred type"
910 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
911 , text "is as general as its" <+> what <+> text "signature"
912 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
913 ; return (tidy_env2, msg) }
914 where
915 what = case mb_sig of
916 Nothing -> text "inferred"
917 Just sig | isPartialSig sig -> text "(partial)"
918 | otherwise -> empty
919
920
921 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
922 mk_inf_msg poly_name poly_ty tidy_env
923 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
924 ; let msg = vcat [ text "When checking the inferred type"
925 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
926 ; return (tidy_env1, msg) }
927
928
929 -- | Warn the user about polymorphic local binders that lack type signatures.
930 localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
931 localSigWarn flag id mb_sig
932 | Just _ <- mb_sig = return ()
933 | not (isSigmaTy (idType id)) = return ()
934 | otherwise = warnMissingSignatures flag msg id
935 where
936 msg = text "Polymorphic local binding with no type signature:"
937
938 warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
939 warnMissingSignatures flag msg id
940 = do { env0 <- tcInitTidyEnv
941 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
942 ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
943 where
944 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
945
946 checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
947 -- Example:
948 -- f :: Eq a => a -> a
949 -- K f = e
950 -- The MR applies, but the signature is overloaded, and it's
951 -- best to complain about this directly
952 -- c.f Trac #11339
953 checkOverloadedSig monomorphism_restriction_applies sig
954 | not (null (sig_inst_theta sig))
955 , monomorphism_restriction_applies
956 , let orig_sig = sig_inst_sig sig
957 = setSrcSpan (sig_loc orig_sig) $
958 failWith $
959 hang (text "Overloaded signature conflicts with monomorphism restriction")
960 2 (ppr orig_sig)
961 | otherwise
962 = return ()
963
964 {- Note [Partial type signatures and generalisation]
965 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
966 If /any/ of the signatures in the gropu is a partial type signature
967 f :: _ -> Int
968 then we *always* use the InferGen plan, and hence tcPolyInfer.
969 We do this even for a local binding with -XMonoLocalBinds, when
970 we normally use NoGen.
971
972 Reasons:
973 * The TcSigInfo for 'f' has a unification variable for the '_',
974 whose TcLevel is one level deeper than the current level.
975 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
976 the TcLevel like InferGen, so we lose the level invariant.
977
978 * The signature might be f :: forall a. _ -> a
979 so it really is polymorphic. It's not clear what it would
980 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
981 in the (Just sig) case, checks that if there is a signature
982 then we are using LetLclBndr, and hence a nested AbsBinds with
983 increased TcLevel
984
985 It might be possible to fix these difficulties somehow, but there
986 doesn't seem much point. Indeed, adding a partial type signature is a
987 way to get per-binding inferred generalisation.
988
989 We apply the MR if /all/ of the partial signatures lack a context.
990 In particular (Trac #11016):
991 f2 :: (?loc :: Int) => _
992 f2 = ?loc
993 It's stupid to apply the MR here. This test includes an extra-constraints
994 wildcard; that is, we don't apply the MR if you write
995 f3 :: _ => blah
996
997 Note [Validity of inferred types]
998 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
999 We need to check inferred type for validity, in case it uses language
1000 extensions that are not turned on. The principle is that if the user
1001 simply adds the inferred type to the program source, it'll compile fine.
1002 See #8883.
1003
1004 Examples that might fail:
1005 - the type might be ambiguous
1006
1007 - an inferred theta that requires type equalities e.g. (F a ~ G b)
1008 or multi-parameter type classes
1009 - an inferred type that includes unboxed tuples
1010
1011
1012 Note [Impedence matching]
1013 ~~~~~~~~~~~~~~~~~~~~~~~~~
1014 Consider
1015 f 0 x = x
1016 f n x = g [] (not x)
1017
1018 g [] y = f 10 y
1019 g _ y = f 9 y
1020
1021 After typechecking we'll get
1022 f_mono_ty :: a -> Bool -> Bool
1023 g_mono_ty :: [b] -> Bool -> Bool
1024 with constraints
1025 (Eq a, Num a)
1026
1027 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
1028 The types we really want for f and g are
1029 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
1030 g :: forall b. [b] -> Bool -> Bool
1031
1032 We can get these by "impedance matching":
1033 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
1034 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
1035
1036 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
1037 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
1038
1039 Suppose the shared quantified tyvars are qtvs and constraints theta.
1040 Then we want to check that
1041 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1042 and the proof is the impedance matcher.
1043
1044 Notice that the impedance matcher may do defaulting. See Trac #7173.
1045
1046 It also cleverly does an ambiguity check; for example, rejecting
1047 f :: F a -> F a
1048 where F is a non-injective type function.
1049 -}
1050
1051 {- *********************************************************************
1052 * *
1053 Vectorisation
1054 * *
1055 ********************************************************************* -}
1056
1057 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1058 tcVectDecls decls
1059 = do { decls' <- mapM (wrapLocM tcVect) decls
1060 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1061 dups = findDupsEq (==) ids
1062 ; mapM_ reportVectDups dups
1063 ; traceTcConstraints "End of tcVectDecls"
1064 ; return decls'
1065 }
1066 where
1067 reportVectDups (first:_second:_more)
1068 = addErrAt (getSrcSpan first) $
1069 text "Duplicate vectorisation declarations for" <+> ppr first
1070 reportVectDups _ = return ()
1071
1072 --------------
1073 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1074 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1075 -- type of the original definition as this requires internals of the vectoriser not available
1076 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1077 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1078 -- from the vectoriser here.
1079 tcVect (HsVect s name rhs)
1080 = addErrCtxt (vectCtxt name) $
1081 do { var <- wrapLocM tcLookupId name
1082 ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
1083 ; rhs_id <- tcLookupId rhs_var_name
1084 ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
1085 }
1086
1087 tcVect (HsNoVect s name)
1088 = addErrCtxt (vectCtxt name) $
1089 do { var <- wrapLocM tcLookupId name
1090 ; return $ HsNoVect s var
1091 }
1092 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1093 = addErrCtxt (vectCtxt lname) $
1094 do { tycon <- tcLookupLocatedTyCon lname
1095 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1096 || isJust rhs_name -- or we explicitly provide a vectorised type
1097 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1098 )
1099 scalarTyConMustBeNullary
1100
1101 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1102 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1103 }
1104 tcVect (HsVectTypeOut _ _ _)
1105 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1106 tcVect (HsVectClassIn _ lname)
1107 = addErrCtxt (vectCtxt lname) $
1108 do { cls <- tcLookupLocatedClass lname
1109 ; return $ HsVectClassOut cls
1110 }
1111 tcVect (HsVectClassOut _)
1112 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1113 tcVect (HsVectInstIn linstTy)
1114 = addErrCtxt (vectCtxt linstTy) $
1115 do { (cls, tys) <- tcHsVectInst linstTy
1116 ; inst <- tcLookupInstance cls tys
1117 ; return $ HsVectInstOut inst
1118 }
1119 tcVect (HsVectInstOut _)
1120 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1121
1122 vectCtxt :: Outputable thing => thing -> SDoc
1123 vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing
1124
1125 scalarTyConMustBeNullary :: MsgDoc
1126 scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"
1127
1128 {-
1129 Note [SPECIALISE pragmas]
1130 ~~~~~~~~~~~~~~~~~~~~~~~~~
1131 There is no point in a SPECIALISE pragma for a non-overloaded function:
1132 reverse :: [a] -> [a]
1133 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1134
1135 But SPECIALISE INLINE *can* make sense for GADTS:
1136 data Arr e where
1137 ArrInt :: !Int -> ByteArray# -> Arr Int
1138 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1139
1140 (!:) :: Arr e -> Int -> e
1141 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1142 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1143 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1144 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1145
1146 When (!:) is specialised it becomes non-recursive, and can usefully
1147 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1148 for a non-overloaded function.
1149
1150 ************************************************************************
1151 * *
1152 tcMonoBinds
1153 * *
1154 ************************************************************************
1155
1156 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1157 The signatures have been dealt with already.
1158
1159 Note [Pattern bindings]
1160 ~~~~~~~~~~~~~~~~~~~~~~~
1161 The rule for typing pattern bindings is this:
1162
1163 ..sigs..
1164 p = e
1165
1166 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1167 typechecks exactly like
1168
1169 ..sigs..
1170 x = e -- Inferred type
1171 v1 = case x of p -> v1
1172 ..
1173 vn = case x of p -> vn
1174
1175 Note that
1176 (f :: forall a. a -> a) = id
1177 should not typecheck because
1178 case id of { (f :: forall a. a->a) -> f }
1179 will not typecheck.
1180
1181 Note [Instantiate when inferring a type]
1182 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1183 Consider
1184 f = (*)
1185 As there is no incentive to instantiate the RHS, tcMonoBinds will
1186 produce a type of forall a. Num a => a -> a -> a for `f`. This will then go
1187 through simplifyInfer and such, remaining unchanged.
1188
1189 There are two problems with this:
1190 1) If the definition were `g _ = (*)`, we get a very unusual type of
1191 `forall {a}. a -> forall b. Num b => b -> b -> b` for `g`. This is
1192 surely confusing for users.
1193
1194 2) The monomorphism restriction can't work. The MR is dealt with in
1195 simplifyInfer, and simplifyInfer has no way of instantiating. This
1196 could perhaps be worked around, but it may be hard to know even
1197 when instantiation should happen.
1198
1199 There is an easy solution to both problems: instantiate (deeply) when
1200 inferring a type. So that's what we do. Note that this decision is
1201 user-facing.
1202
1203 We do this deep instantiation in tcMonoBinds, in the FunBind case
1204 only, and only when we do not have a type signature. Conveniently,
1205 the fun_co_fn field of FunBind gives a place to record the coercion.
1206
1207 We do not need to do this
1208 * for PatBinds, because we don't have a function type
1209 * for FunBinds where we have a signature, bucause we aren't doing inference
1210 -}
1211
1212 data MonoBindInfo = MBI { mbi_poly_name :: Name
1213 , mbi_sig :: Maybe TcIdSigInst
1214 , mbi_mono_id :: TcId }
1215
1216 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1217 -- i.e. the binders are mentioned in their RHSs, and
1218 -- we are not rescued by a type signature
1219 -> TcSigFun -> LetBndrSpec
1220 -> [LHsBind Name]
1221 -> TcM (LHsBinds TcId, [MonoBindInfo])
1222 tcMonoBinds is_rec sig_fn no_gen
1223 [ L b_loc (FunBind { fun_id = L nm_loc name,
1224 fun_matches = matches, bind_fvs = fvs })]
1225 -- Single function binding,
1226 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1227 , Nothing <- sig_fn name -- ...with no type signature
1228 = -- In this very special case we infer the type of the
1229 -- right hand side first (it may have a higher-rank type)
1230 -- and *then* make the monomorphic Id for the LHS
1231 -- e.g. f = \(x::forall a. a->a) -> <body>
1232 -- We want to infer a higher-rank type for f
1233 setSrcSpan b_loc $
1234 do { rhs_ty <- newOpenInferExpType
1235 ; (co_fn, matches')
1236 <- tcExtendIdBndrs [TcIdBndr_ExpType name rhs_ty NotTopLevel] $
1237 -- We extend the error context even for a non-recursive
1238 -- function so that in type error messages we show the
1239 -- type of the thing whose rhs we are type checking
1240 tcMatchesFun (L nm_loc name) matches rhs_ty
1241 ; rhs_ty <- readExpType rhs_ty
1242
1243 -- Deeply instantiate the inferred type
1244 -- See Note [Instantiate when inferring a type]
1245 ; let orig = matchesCtOrigin matches
1246 ; rhs_ty <- zonkTcType rhs_ty -- NB: zonk to uncover any foralls
1247 ; (inst_wrap, rhs_ty) <- addErrCtxtM (instErrCtxt name rhs_ty) $
1248 deeplyInstantiate orig rhs_ty
1249
1250 ; mono_id <- newLetBndr no_gen name rhs_ty
1251 ; return (unitBag $ L b_loc $
1252 FunBind { fun_id = L nm_loc mono_id,
1253 fun_matches = matches', bind_fvs = fvs,
1254 fun_co_fn = inst_wrap <.> co_fn, fun_tick = [] },
1255 [MBI { mbi_poly_name = name
1256 , mbi_sig = Nothing
1257 , mbi_mono_id = mono_id }]) }
1258
1259 tcMonoBinds _ sig_fn no_gen binds
1260 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1261
1262 -- Bring the monomorphic Ids, into scope for the RHSs
1263 ; let mono_infos = getMonoBindInfo tc_binds
1264 rhs_id_env = [ (name, mono_id)
1265 | MBI { mbi_poly_name = name
1266 , mbi_sig = mb_sig
1267 , mbi_mono_id = mono_id } <- mono_infos
1268 , case mb_sig of
1269 Just sig -> isPartialSig sig
1270 Nothing -> True ]
1271 -- A monomorphic binding for each term variable that lacks
1272 -- a complete type sig. (Ones with a sig are already in scope.)
1273
1274 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1275 | (n,id) <- rhs_id_env]
1276 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1277 mapM (wrapLocM tcRhs) tc_binds
1278
1279 ; return (listToBag binds', mono_infos) }
1280
1281
1282 ------------------------
1283 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1284 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1285 -- if there's a signature for it, use the instantiated signature type
1286 -- otherwise invent a type variable
1287 -- You see that quite directly in the FunBind case.
1288 --
1289 -- But there's a complication for pattern bindings:
1290 -- data T = MkT (forall a. a->a)
1291 -- MkT f = e
1292 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1293 -- but we want to get (f::forall a. a->a) as the RHS environment.
1294 -- The simplest way to do this is to typecheck the pattern, and then look up the
1295 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1296 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1297
1298 data TcMonoBind -- Half completed; LHS done, RHS not done
1299 = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
1300 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1301
1302 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1303 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1304 = do { mono_info <- tcLhsId sig_fn no_gen name
1305 ; return (TcFunBind mono_info nm_loc matches) }
1306
1307 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1308 = do { let bndr_names = collectPatBinders pat
1309 ; mbis <- mapM (tcLhsId sig_fn no_gen) bndr_names
1310 -- See Note [Existentials in pattern bindings]
1311
1312 ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
1313 bndr_names `zip` map mbi_mono_id mbis
1314
1315 ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
1316 | mbi <- mbis, let id = mbi_mono_id mbi ]
1317 $$ ppr no_gen)
1318
1319 ; ((pat', _), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1320 tcInfer $ \ exp_ty ->
1321 tcLetPat inst_sig_fun pat exp_ty $
1322 return () -- mapM (lookup_info inst_sig_fun) bndr_names
1323
1324 ; return (TcPatBind mbis pat' grhss pat_ty) }
1325
1326 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1327 -- AbsBind, VarBind impossible
1328
1329 -------------------
1330 data LetBndrSpec
1331 = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds
1332 -- so clone a fresh binder for the local monomorphic Id
1333
1334 | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going
1335 -- to be an AbsBinds; So we must bind the global version
1336 -- of the binder right away.
1337 -- And here is the inline-pragma information
1338
1339 instance Outputable LetBndrSpec where
1340 ppr LetLclBndr = text "LetLclBndr"
1341 ppr (LetGblBndr {}) = text "LetGblBndr"
1342
1343 tcLhsId :: TcSigFun -> LetBndrSpec -> Name -> TcM MonoBindInfo
1344 tcLhsId sig_fn no_gen name
1345 | Just (TcIdSig sig) <- sig_fn name
1346 = -- A partial type signature on a FunBind, in a mixed group
1347 -- e.g. f :: _ -> _
1348 -- f x = ...g...
1349 -- Just g = ...f...
1350 -- Hence always typechecked with InferGen; hence LetLclBndr
1351 --
1352 -- A compelete type sig on a FunBind is checked with CheckGen
1353 -- and does not go via tcLhsId
1354 do { inst_sig <- tcInstSig sig
1355 ; the_id <- newSigLetBndr no_gen name inst_sig
1356 ; return (MBI { mbi_poly_name = name
1357 , mbi_sig = Just inst_sig
1358 , mbi_mono_id = the_id }) }
1359
1360 | otherwise
1361 = -- No type signature, plan InferGen (LetLclBndr) or NoGen (LetGblBndr)
1362 do { mono_ty <- newOpenFlexiTyVarTy
1363 ; mono_id <- newLetBndr no_gen name mono_ty
1364 ; return (MBI { mbi_poly_name = name
1365 , mbi_sig = Nothing
1366 , mbi_mono_id = mono_id }) }
1367
1368 ------------
1369 newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
1370 newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
1371 | CompleteSig { sig_bndr = poly_id } <- id_sig
1372 = addInlinePrags poly_id (lookupPragEnv prags name)
1373 newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
1374 = newLetBndr no_gen name tau
1375
1376 newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
1377 -- In the polymorphic case when we are going to generalise
1378 -- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"
1379 -- of the Id; the original name will be bound to the polymorphic version
1380 -- by the AbsBinds
1381 -- In the monomorphic case when we are not going to generalise
1382 -- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,
1383 -- and we use the original name directly
1384 newLetBndr LetLclBndr name ty
1385 = do { mono_name <- cloneLocalName name
1386 ; return (mkLocalId mono_name ty) }
1387 newLetBndr (LetGblBndr prags) name ty
1388 = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)
1389
1390 -------------------
1391 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1392 tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
1393 loc matches)
1394 = tcExtendIdBinderStackForRhs [info] $
1395 tcExtendTyVarEnvForRhs mb_sig $
1396 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1397 ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
1398 matches (mkCheckExpType $ idType mono_id)
1399 ; return ( FunBind { fun_id = L loc mono_id
1400 , fun_matches = matches'
1401 , fun_co_fn = co_fn
1402 , bind_fvs = placeHolderNamesTc
1403 , fun_tick = [] } ) }
1404
1405 tcRhs (TcPatBind infos pat' grhss pat_ty)
1406 = -- When we are doing pattern bindings we *don't* bring any scoped
1407 -- type variables into scope unlike function bindings
1408 -- Wny not? They are not completely rigid.
1409 -- That's why we have the special case for a single FunBind in tcMonoBinds
1410 tcExtendIdBinderStackForRhs infos $
1411 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1412 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1413 tcGRHSsPat grhss pat_ty
1414 ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
1415 , pat_rhs_ty = pat_ty
1416 , bind_fvs = placeHolderNamesTc
1417 , pat_ticks = ([],[]) } )}
1418
1419 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
1420 tcExtendTyVarEnvForRhs Nothing thing_inside
1421 = thing_inside
1422 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1423 = tcExtendTyVarEnvFromSig sig thing_inside
1424
1425 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
1426 tcExtendTyVarEnvFromSig sig_inst thing_inside
1427 | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
1428 = tcExtendTyVarEnv2 wcs $
1429 tcExtendTyVarEnv2 skol_prs $
1430 thing_inside
1431
1432 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1433 -- Extend the TcIdBinderStack for the RHS of the binding, with
1434 -- the monomorphic Id. That way, if we have, say
1435 -- f = \x -> blah
1436 -- and something goes wrong in 'blah', we get a "relevant binding"
1437 -- looking like f :: alpha -> beta
1438 -- This applies if 'f' has a type signature too:
1439 -- f :: forall a. [a] -> [a]
1440 -- f x = True
1441 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1442 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1443 -- would not be reported as relevant, because its type is closed
1444 tcExtendIdBinderStackForRhs infos thing_inside
1445 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
1446 | MBI { mbi_mono_id = mono_id } <- infos ]
1447 thing_inside
1448 -- NotTopLevel: it's a monomorphic binding
1449
1450 ---------------------
1451 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1452 getMonoBindInfo tc_binds
1453 = foldr (get_info . unLoc) [] tc_binds
1454 where
1455 get_info (TcFunBind info _ _) rest = info : rest
1456 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1457
1458 {- Note [Existentials in pattern bindings]
1459 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1460 Consider (typecheck/should_compile/ExPat):
1461 data T where
1462 MkT :: Integral a => a -> Int -> T
1463
1464 and suppose t :: T. Which of these pattern bindings are ok?
1465
1466 E1. let { MkT p _ = t } in <body>
1467
1468 E2. let { MkT _ q = t } in <body>
1469
1470 E3. let { MkT (toInteger -> r) _ = t } in <body>
1471
1472 Well (E1) is clearly wrong because the existential 'a' escapes.
1473 What type could 'p' possibly have?
1474
1475 But (E2) is fine, despite the existential pattern, because
1476 q::Int, and nothing escapes.
1477
1478 Even (E3) is fine. The existential pattern binds a dictionary
1479 for (Integral a) which the view pattern can use to convert the
1480 a-valued field to an Integer, so r :: Integer.
1481
1482 An easy way to see all three is to imagine the desugaring.
1483 For (2) it would look like
1484 let q = case t of MkT _ q' -> q'
1485 in <body>
1486
1487 We typecheck pattern bindings as follows:
1488 1. In tcLhs we bind q'::alpha, for each variable q bound by the
1489 pattern, where q' is a fresh name, and alpha is a fresh
1490 unification variable; it will be the monomorphic verion of q that
1491 we later generalise
1492
1493 It's very important that these fresh unification variables
1494 alpha are born here, not deep under implications as would happen
1495 if we allocated them when we encountered q during tcPat.
1496
1497 2. Still in tcLhs, we build a little environment mappting "q" ->
1498 q':alpha, and pass that to tcLetPet.
1499
1500 3. Then tcLhs invokes tcLetPat to typecheck the patter as usual:
1501 - When tcLetPat finds an existential constructor, it binds fresh
1502 type variables and dictionaries as usual, and emits an
1503 implication constraint.
1504
1505 - When tcLetPat finds a variable (TcPat.tcPatBndr) it looks it up
1506 in the little environment, which should always succeed. And
1507 uses tcSubTypeET to connect the type of that variable with the
1508 expected type of the pattern.
1509
1510 And that's it! The implication constraints check for the skolem
1511 escape. It's quite simple and neat, and more exressive than before
1512 e.g. GHC 8.0 rejects (E2) and (E3).
1513
1514
1515 ************************************************************************
1516 * *
1517 Generalisation
1518 * *
1519 ********************************************************************* -}
1520
1521 data GeneralisationPlan
1522 = NoGen -- No generalisation, no AbsBinds
1523
1524 | InferGen -- Implicit generalisation; there is an AbsBinds
1525 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1526
1527 | CheckGen (LHsBind Name) TcIdSigInfo
1528 -- One FunBind with a signature
1529 -- Explicit generalisation; there is an AbsBindsSig
1530
1531 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1532 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1533
1534 instance Outputable GeneralisationPlan where
1535 ppr NoGen = text "NoGen"
1536 ppr (InferGen b) = text "InferGen" <+> ppr b
1537 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1538
1539 decideGeneralisationPlan
1540 :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun
1541 -> GeneralisationPlan
1542 decideGeneralisationPlan dflags lbinds closed sig_fn
1543 | unlifted_pat_binds = NoGen
1544 | has_partial_sigs = InferGen (and partial_sig_mrs)
1545 | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
1546 | mono_local_binds closed = NoGen
1547 | otherwise = InferGen mono_restriction
1548 where
1549 binds = map unLoc lbinds
1550
1551 partial_sig_mrs :: [Bool]
1552 -- One for each parital signature (so empty => no partial sigs)
1553 -- The Bool is True if the signature has no constraint context
1554 -- so we should apply the MR
1555 -- See Note [Partial type signatures and generalisation]
1556 partial_sig_mrs
1557 = [ null theta
1558 | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
1559 <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
1560 , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
1561
1562 has_partial_sigs = not (null partial_sig_mrs)
1563 unlifted_pat_binds = any isUnliftedHsBind binds
1564 -- Unlifted patterns (unboxed tuple) must not
1565 -- be polymorphic, because we are going to force them
1566 -- See Trac #4498, #8762
1567
1568 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1569 && any restricted binds
1570
1571 mono_local_binds ClosedGroup = False
1572 mono_local_binds _ = xopt LangExt.MonoLocalBinds dflags
1573
1574 -- With OutsideIn, all nested bindings are monomorphic
1575 -- except a single function binding with a signature
1576 one_funbind_with_sig
1577 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1578 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1579 = Just (lbind, sig)
1580 | otherwise
1581 = Nothing
1582
1583 -- The Haskell 98 monomorphism restriction
1584 restricted (PatBind {}) = True
1585 restricted (VarBind { var_id = v }) = no_sig v
1586 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1587 && no_sig (unLoc v)
1588 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1589 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1590 restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"
1591
1592 restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
1593 restricted_match _ = False
1594 -- No args => like a pattern binding
1595 -- Some args => a function binding
1596
1597 no_sig n = noCompleteSig (sig_fn n)
1598
1599 isClosedBndrGroup :: Bag (LHsBind Name) -> TcM IsGroupClosed
1600 isClosedBndrGroup binds = do
1601 type_env <- getLclTypeEnv
1602 if foldUFM (is_closed_ns type_env) True fv_env
1603 then return ClosedGroup
1604 else return $ NonClosedGroup fv_env
1605 where
1606 fv_env :: NameEnv NameSet
1607 fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
1608
1609 bindFvs :: HsBindLR Name idR -> [(Name, NameSet)]
1610 bindFvs (FunBind { fun_id = f, bind_fvs = fvs })
1611 = [(unLoc f, fvs)]
1612 bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
1613 = [(b, fvs) | b <- collectPatBinders pat]
1614 bindFvs _
1615 = []
1616
1617 is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
1618 is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns
1619 -- ns are the Names referred to from the RHS of this bind
1620
1621 is_closed_id :: TcTypeEnv -> Name -> Bool
1622 -- See Note [Bindings with closed types] in TcRnTypes
1623 is_closed_id type_env name
1624 | Just thing <- lookupNameEnv type_env name
1625 = case thing of
1626 ATcId { tct_info = ClosedLet } -> True -- This is the key line
1627 ATcId {} -> False
1628 ATyVar {} -> False -- In-scope type variables
1629 AGlobal {} -> True -- are not closed!
1630 _ -> pprPanic "is_closed_id" (ppr name)
1631 | otherwise
1632 = True
1633 -- The free-var set for a top level binding mentions
1634 -- imported things too, so that we can report unused imports
1635 -- These won't be in the local type env.
1636 -- Ditto class method etc from the current module
1637
1638 -------------------
1639 checkStrictBinds :: TopLevelFlag -> RecFlag
1640 -> [LHsBind Name]
1641 -> LHsBinds TcId -> [Id]
1642 -> TcM ()
1643 -- Check that non-overloaded unlifted bindings are
1644 -- a) non-recursive,
1645 -- b) not top level,
1646 -- c) not a multiple-binding group (more or less implied by (a))
1647
1648 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1649 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
1650 = do { check (isNotTopLevel top_lvl)
1651 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
1652 ; check (isNonRec rec_group)
1653 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
1654
1655 ; check (all is_monomorphic (bagToList tc_binds))
1656 (polyBindErr orig_binds)
1657 -- data Ptr a = Ptr Addr#
1658 -- f x = let p@(Ptr y) = ... in ...
1659 -- Here the binding for 'p' is polymorphic, but does
1660 -- not mix with an unlifted binding for 'y'. You should
1661 -- use a bang pattern. Trac #6078.
1662
1663 ; check (isSingleton orig_binds)
1664 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
1665
1666 -- Complain about a binding that looks lazy
1667 -- e.g. let I# y = x in ...
1668 -- Remember, in checkStrictBinds we are going to do strict
1669 -- matching, so (for software engineering reasons) we insist
1670 -- that the strictness is manifest on each binding
1671 -- However, lone (unboxed) variables are ok
1672 ; check (not any_pat_looks_lazy)
1673 (unliftedMustBeBang orig_binds) }
1674 | otherwise
1675 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
1676 return ()
1677 where
1678 any_unlifted_bndr = any is_unlifted poly_ids
1679 any_strict_pat = any (isUnliftedHsBind . unLoc) orig_binds
1680 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1681
1682 is_unlifted id = case tcSplitSigmaTy (idType id) of
1683 (_, _, rho) -> isUnliftedType rho
1684 -- For the is_unlifted check, we need to look inside polymorphism
1685 -- and overloading. E.g. x = (# 1, True #)
1686 -- would get type forall a. Num a => (# a, Bool #)
1687 -- and we want to reject that. See Trac #9140
1688
1689 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1690 = null tvs && null evs
1691 is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }))
1692 = null tvs && null evs
1693 is_monomorphic _ = True
1694
1695 check :: Bool -> MsgDoc -> TcM ()
1696 -- Just like checkTc, but with a special case for module GHC.Prim:
1697 -- see Note [Compiling GHC.Prim]
1698 check True _ = return ()
1699 check False err = do { mod <- getModule
1700 ; checkTc (mod == gHC_PRIM) err }
1701
1702 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1703 unliftedMustBeBang binds
1704 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1705 2 (vcat (map ppr binds))
1706
1707 polyBindErr :: [LHsBind Name] -> SDoc
1708 polyBindErr binds
1709 = hang (text "You can't mix polymorphic and unlifted bindings")
1710 2 (vcat [vcat (map ppr binds),
1711 text "Probable fix: add a type signature"])
1712
1713 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1714 strictBindErr flavour any_unlifted_bndr binds
1715 = hang (text flavour <+> msg <+> text "aren't allowed:")
1716 2 (vcat (map ppr binds))
1717 where
1718 msg | any_unlifted_bndr = text "bindings for unlifted types"
1719 | otherwise = text "bang-pattern or unboxed-tuple bindings"
1720
1721
1722 {- Note [Compiling GHC.Prim]
1723 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1724 Module GHC.Prim has no source code: it is the host module for
1725 primitive, built-in functions and types. However, for Haddock-ing
1726 purposes we generate (via utils/genprimopcode) a fake source file
1727 GHC/Prim.hs, and give it to Haddock, so that it can generate
1728 documentation. It contains definitions like
1729 nullAddr# :: NullAddr#
1730 which would normally be rejected as a top-level unlifted binding. But
1731 we don't want to complain, because we are only "compiling" this fake
1732 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
1733 in checkStrictBinds.
1734
1735 (We only make the test if things look wrong, so there is no cost in
1736 the common case.) -}
1737
1738
1739 {- *********************************************************************
1740 * *
1741 Error contexts and messages
1742 * *
1743 ********************************************************************* -}
1744
1745 -- This one is called on LHS, when pat and grhss are both Name
1746 -- and on RHS, when pat is TcId and grhss is still Name
1747 patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)
1748 => LPat id -> GRHSs Name body -> SDoc
1749 patMonoBindsCtxt pat grhss
1750 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
1751
1752 instErrCtxt :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
1753 instErrCtxt name ty env
1754 = do { let (env', ty') = tidyOpenType env ty
1755 ; return (env', hang (text "When instantiating" <+> quotes (ppr name) <>
1756 text ", initially inferred to have" $$
1757 text "this overly-general type:")
1758 2 (ppr ty') $$
1759 extra) }
1760 where
1761 extra = sdocWithDynFlags $ \dflags ->
1762 ppWhen (xopt LangExt.MonomorphismRestriction dflags) $
1763 text "NB: This instantiation can be caused by the" <+>
1764 text "monomorphism restriction."