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