Test for type synonym loops on TyCon.
[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 (tyCoVarsOfTypes annotated_theta
826 `unionVarSet` tau_tvs)
827 my_theta = pickCapturedPreds free_tvs inferred_theta
828
829 -- Report the inferred constraints for an extra-constraints wildcard/hole as
830 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
831 -- case, the extra inferred constraints are accepted without complaining.
832 -- NB: inferred_theta already includes all the annotated constraints
833 inferred_diff = [ pred
834 | pred <- my_theta
835 , all (not . (`eqType` pred)) annotated_theta ]
836 ; ctuple <- mk_ctuple inferred_diff
837 ; writeMetaTyVar wc_var ctuple
838 ; traceTc "completeTheta" $
839 vcat [ ppr sig
840 , ppr annotated_theta, ppr inferred_theta
841 , ppr inferred_diff ]
842
843 ; return (mk_binders free_tvs, my_theta) }
844
845 | otherwise -- A complete type signature is dealt with in mkInferredPolyId
846 = pprPanic "chooseInferredQuantifiers" (ppr sig)
847
848 where
849 spec_tv_set = mkVarSet $ map snd annotated_tvs
850 mk_binders free_tvs
851 = [ mkTyVarBinder vis tv
852 | tv <- qtvs
853 , tv `elemVarSet` free_tvs
854 , let vis | tv `elemVarSet` spec_tv_set = Specified
855 | otherwise = Inferred ]
856 -- Pulling from qtvs maintains original order
857
858 mk_ctuple [pred] = return pred
859 mk_ctuple preds = do { tc <- tcLookupTyCon (cTupleTyConName (length preds))
860 ; return (mkTyConApp tc preds) }
861
862 mk_impedence_match_msg :: MonoBindInfo
863 -> TcType -> TcType
864 -> TidyEnv -> TcM (TidyEnv, SDoc)
865 -- This is a rare but rather awkward error messages
866 mk_impedence_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
867 inf_ty sig_ty tidy_env
868 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
869 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
870 ; let msg = vcat [ text "When checking that the inferred type"
871 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
872 , text "is as general as its" <+> what <+> text "signature"
873 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
874 ; return (tidy_env2, msg) }
875 where
876 what = case mb_sig of
877 Nothing -> text "inferred"
878 Just sig | isPartialSig sig -> text "(partial)"
879 | otherwise -> empty
880
881
882 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
883 mk_inf_msg poly_name poly_ty tidy_env
884 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
885 ; let msg = vcat [ text "When checking the inferred type"
886 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
887 ; return (tidy_env1, msg) }
888
889
890 -- | Warn the user about polymorphic local binders that lack type signatures.
891 localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
892 localSigWarn flag id mb_sig
893 | Just _ <- mb_sig = return ()
894 | not (isSigmaTy (idType id)) = return ()
895 | otherwise = warnMissingSignatures flag msg id
896 where
897 msg = text "Polymorphic local binding with no type signature:"
898
899 warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
900 warnMissingSignatures flag msg id
901 = do { env0 <- tcInitTidyEnv
902 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
903 ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
904 where
905 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
906
907 checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
908 -- Example:
909 -- f :: Eq a => a -> a
910 -- K f = e
911 -- The MR applies, but the signature is overloaded, and it's
912 -- best to complain about this directly
913 -- c.f Trac #11339
914 checkOverloadedSig monomorphism_restriction_applies sig
915 | not (null (sig_inst_theta sig))
916 , monomorphism_restriction_applies
917 , let orig_sig = sig_inst_sig sig
918 = setSrcSpan (sig_loc orig_sig) $
919 failWith $
920 hang (text "Overloaded signature conflicts with monomorphism restriction")
921 2 (ppr orig_sig)
922 | otherwise
923 = return ()
924
925 {- Note [Partial type signatures and generalisation]
926 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
927 If /any/ of the signatures in the gropu is a partial type signature
928 f :: _ -> Int
929 then we *always* use the InferGen plan, and hence tcPolyInfer.
930 We do this even for a local binding with -XMonoLocalBinds, when
931 we normally use NoGen.
932
933 Reasons:
934 * The TcSigInfo for 'f' has a unification variable for the '_',
935 whose TcLevel is one level deeper than the current level.
936 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
937 the TcLevel like InferGen, so we lose the level invariant.
938
939 * The signature might be f :: forall a. _ -> a
940 so it really is polymorphic. It's not clear what it would
941 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
942 in the (Just sig) case, checks that if there is a signature
943 then we are using LetLclBndr, and hence a nested AbsBinds with
944 increased TcLevel
945
946 It might be possible to fix these difficulties somehow, but there
947 doesn't seem much point. Indeed, adding a partial type signature is a
948 way to get per-binding inferred generalisation.
949
950 We apply the MR if /all/ of the partial signatures lack a context.
951 In particular (Trac #11016):
952 f2 :: (?loc :: Int) => _
953 f2 = ?loc
954 It's stupid to apply the MR here. This test includes an extra-constraints
955 wildcard; that is, we don't apply the MR if you write
956 f3 :: _ => blah
957
958 Note [Validity of inferred types]
959 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
960 We need to check inferred type for validity, in case it uses language
961 extensions that are not turned on. The principle is that if the user
962 simply adds the inferred type to the program source, it'll compile fine.
963 See #8883.
964
965 Examples that might fail:
966 - the type might be ambiguous
967
968 - an inferred theta that requires type equalities e.g. (F a ~ G b)
969 or multi-parameter type classes
970 - an inferred type that includes unboxed tuples
971
972
973 Note [Impedence matching]
974 ~~~~~~~~~~~~~~~~~~~~~~~~~
975 Consider
976 f 0 x = x
977 f n x = g [] (not x)
978
979 g [] y = f 10 y
980 g _ y = f 9 y
981
982 After typechecking we'll get
983 f_mono_ty :: a -> Bool -> Bool
984 g_mono_ty :: [b] -> Bool -> Bool
985 with constraints
986 (Eq a, Num a)
987
988 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
989 The types we really want for f and g are
990 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
991 g :: forall b. [b] -> Bool -> Bool
992
993 We can get these by "impedance matching":
994 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
995 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
996
997 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
998 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
999
1000 Suppose the shared quantified tyvars are qtvs and constraints theta.
1001 Then we want to check that
1002 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1003 and the proof is the impedance matcher.
1004
1005 Notice that the impedance matcher may do defaulting. See Trac #7173.
1006
1007 It also cleverly does an ambiguity check; for example, rejecting
1008 f :: F a -> F a
1009 where F is a non-injective type function.
1010 -}
1011
1012 {- *********************************************************************
1013 * *
1014 Vectorisation
1015 * *
1016 ********************************************************************* -}
1017
1018 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1019 tcVectDecls decls
1020 = do { decls' <- mapM (wrapLocM tcVect) decls
1021 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1022 dups = findDupsEq (==) ids
1023 ; mapM_ reportVectDups dups
1024 ; traceTcConstraints "End of tcVectDecls"
1025 ; return decls'
1026 }
1027 where
1028 reportVectDups (first:_second:_more)
1029 = addErrAt (getSrcSpan first) $
1030 text "Duplicate vectorisation declarations for" <+> ppr first
1031 reportVectDups _ = return ()
1032
1033 --------------
1034 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1035 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1036 -- type of the original definition as this requires internals of the vectoriser not available
1037 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1038 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1039 -- from the vectoriser here.
1040 tcVect (HsVect s name rhs)
1041 = addErrCtxt (vectCtxt name) $
1042 do { var <- wrapLocM tcLookupId name
1043 ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
1044 ; rhs_id <- tcLookupId rhs_var_name
1045 ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
1046 }
1047
1048 tcVect (HsNoVect s name)
1049 = addErrCtxt (vectCtxt name) $
1050 do { var <- wrapLocM tcLookupId name
1051 ; return $ HsNoVect s var
1052 }
1053 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1054 = addErrCtxt (vectCtxt lname) $
1055 do { tycon <- tcLookupLocatedTyCon lname
1056 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1057 || isJust rhs_name -- or we explicitly provide a vectorised type
1058 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1059 )
1060 scalarTyConMustBeNullary
1061
1062 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1063 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1064 }
1065 tcVect (HsVectTypeOut _ _ _)
1066 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1067 tcVect (HsVectClassIn _ lname)
1068 = addErrCtxt (vectCtxt lname) $
1069 do { cls <- tcLookupLocatedClass lname
1070 ; return $ HsVectClassOut cls
1071 }
1072 tcVect (HsVectClassOut _)
1073 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1074 tcVect (HsVectInstIn linstTy)
1075 = addErrCtxt (vectCtxt linstTy) $
1076 do { (cls, tys) <- tcHsVectInst linstTy
1077 ; inst <- tcLookupInstance cls tys
1078 ; return $ HsVectInstOut inst
1079 }
1080 tcVect (HsVectInstOut _)
1081 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1082
1083 vectCtxt :: Outputable thing => thing -> SDoc
1084 vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing
1085
1086 scalarTyConMustBeNullary :: MsgDoc
1087 scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"
1088
1089 {-
1090 Note [SPECIALISE pragmas]
1091 ~~~~~~~~~~~~~~~~~~~~~~~~~
1092 There is no point in a SPECIALISE pragma for a non-overloaded function:
1093 reverse :: [a] -> [a]
1094 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1095
1096 But SPECIALISE INLINE *can* make sense for GADTS:
1097 data Arr e where
1098 ArrInt :: !Int -> ByteArray# -> Arr Int
1099 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1100
1101 (!:) :: Arr e -> Int -> e
1102 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1103 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1104 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1105 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1106
1107 When (!:) is specialised it becomes non-recursive, and can usefully
1108 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1109 for a non-overloaded function.
1110
1111 ************************************************************************
1112 * *
1113 tcMonoBinds
1114 * *
1115 ************************************************************************
1116
1117 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1118 The signatures have been dealt with already.
1119 -}
1120
1121 data MonoBindInfo = MBI { mbi_poly_name :: Name
1122 , mbi_sig :: Maybe TcIdSigInst
1123 , mbi_mono_id :: TcId }
1124
1125 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1126 -- i.e. the binders are mentioned in their RHSs, and
1127 -- we are not rescued by a type signature
1128 -> TcSigFun -> LetBndrSpec
1129 -> [LHsBind Name]
1130 -> TcM (LHsBinds TcId, [MonoBindInfo])
1131 tcMonoBinds is_rec sig_fn no_gen
1132 [ L b_loc (FunBind { fun_id = L nm_loc name,
1133 fun_matches = matches, bind_fvs = fvs })]
1134 -- Single function binding,
1135 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1136 , Nothing <- sig_fn name -- ...with no type signature
1137 = -- Note [Single function non-recursive binding special-case]
1138 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1139 -- In this very special case we infer the type of the
1140 -- right hand side first (it may have a higher-rank type)
1141 -- and *then* make the monomorphic Id for the LHS
1142 -- e.g. f = \(x::forall a. a->a) -> <body>
1143 -- We want to infer a higher-rank type for f
1144 setSrcSpan b_loc $
1145 do { ((co_fn, matches'), rhs_ty)
1146 <- tcInferInst $ \ exp_ty ->
1147 -- tcInferInst: see TcUnify,
1148 -- Note [Deep instantiation of InferResult]
1149 tcExtendIdBndrs [TcIdBndr_ExpType name exp_ty NotTopLevel] $
1150 -- We extend the error context even for a non-recursive
1151 -- function so that in type error messages we show the
1152 -- type of the thing whose rhs we are type checking
1153 tcMatchesFun (L nm_loc name) matches exp_ty
1154
1155 ; mono_id <- newLetBndr no_gen name rhs_ty
1156 ; return (unitBag $ L b_loc $
1157 FunBind { fun_id = L nm_loc mono_id,
1158 fun_matches = matches', bind_fvs = fvs,
1159 fun_co_fn = co_fn, fun_tick = [] },
1160 [MBI { mbi_poly_name = name
1161 , mbi_sig = Nothing
1162 , mbi_mono_id = mono_id }]) }
1163
1164 tcMonoBinds _ sig_fn no_gen binds
1165 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1166
1167 -- Bring the monomorphic Ids, into scope for the RHSs
1168 ; let mono_infos = getMonoBindInfo tc_binds
1169 rhs_id_env = [ (name, mono_id)
1170 | MBI { mbi_poly_name = name
1171 , mbi_sig = mb_sig
1172 , mbi_mono_id = mono_id } <- mono_infos
1173 , case mb_sig of
1174 Just sig -> isPartialSig sig
1175 Nothing -> True ]
1176 -- A monomorphic binding for each term variable that lacks
1177 -- a complete type sig. (Ones with a sig are already in scope.)
1178
1179 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1180 | (n,id) <- rhs_id_env]
1181 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1182 mapM (wrapLocM tcRhs) tc_binds
1183
1184 ; return (listToBag binds', mono_infos) }
1185
1186
1187 ------------------------
1188 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1189 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1190 -- if there's a signature for it, use the instantiated signature type
1191 -- otherwise invent a type variable
1192 -- You see that quite directly in the FunBind case.
1193 --
1194 -- But there's a complication for pattern bindings:
1195 -- data T = MkT (forall a. a->a)
1196 -- MkT f = e
1197 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1198 -- but we want to get (f::forall a. a->a) as the RHS environment.
1199 -- The simplest way to do this is to typecheck the pattern, and then look up the
1200 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1201 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1202
1203 data TcMonoBind -- Half completed; LHS done, RHS not done
1204 = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
1205 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1206
1207 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1208 -- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
1209 -- or NoGen (LetBndrSpec = LetGblBndr)
1210 -- CheckGen is used only for functions with a complete type signature,
1211 -- and tcPolyCheck doesn't use tcMonoBinds at all
1212
1213 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1214 | Just (TcIdSig sig) <- sig_fn name
1215 = -- There is a type signature.
1216 -- It must be partial; if complete we'd be in tcPolyCheck!
1217 -- e.g. f :: _ -> _
1218 -- f x = ...g...
1219 -- Just g = ...f...
1220 -- Hence always typechecked with InferGen
1221 do { mono_info <- tcLhsSigId no_gen (name, sig)
1222 ; return (TcFunBind mono_info nm_loc matches) }
1223
1224 | otherwise -- No type signature
1225 = do { mono_ty <- newOpenFlexiTyVarTy
1226 ; mono_id <- newLetBndr no_gen name mono_ty
1227 ; let mono_info = MBI { mbi_poly_name = name
1228 , mbi_sig = Nothing
1229 , mbi_mono_id = mono_id }
1230 ; return (TcFunBind mono_info nm_loc matches) }
1231
1232 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1233 = -- See Note [Typechecking pattern bindings]
1234 do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
1235
1236 ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
1237 [ (mbi_poly_name mbi, mbi_mono_id mbi)
1238 | mbi <- sig_mbis ]
1239
1240 -- See Note [Existentials in pattern bindings]
1241 ; ((pat', nosig_mbis), pat_ty)
1242 <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1243 tcInferNoInst $ \ exp_ty ->
1244 tcLetPat inst_sig_fun no_gen pat exp_ty $
1245 mapM lookup_info nosig_names
1246
1247 ; let mbis = sig_mbis ++ nosig_mbis
1248
1249 ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
1250 | mbi <- mbis, let id = mbi_mono_id mbi ]
1251 $$ ppr no_gen)
1252
1253 ; return (TcPatBind mbis pat' grhss pat_ty) }
1254 where
1255 bndr_names = collectPatBinders pat
1256 (nosig_names, sig_names) = partitionWith find_sig bndr_names
1257
1258 find_sig :: Name -> Either Name (Name, TcIdSigInfo)
1259 find_sig name = case sig_fn name of
1260 Just (TcIdSig sig) -> Right (name, sig)
1261 _ -> Left name
1262
1263 -- After typechecking the pattern, look up the binder
1264 -- names that lack a signature, which the pattern has brought
1265 -- into scope.
1266 lookup_info :: Name -> TcM MonoBindInfo
1267 lookup_info name
1268 = do { mono_id <- tcLookupId name
1269 ; return (MBI { mbi_poly_name = name
1270 , mbi_sig = Nothing
1271 , mbi_mono_id = mono_id }) }
1272
1273 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1274 -- AbsBind, VarBind impossible
1275
1276 -------------------
1277 tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
1278 tcLhsSigId no_gen (name, sig)
1279 = do { inst_sig <- tcInstSig sig
1280 ; mono_id <- newSigLetBndr no_gen name inst_sig
1281 ; return (MBI { mbi_poly_name = name
1282 , mbi_sig = Just inst_sig
1283 , mbi_mono_id = mono_id }) }
1284
1285 ------------
1286 newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
1287 newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
1288 | CompleteSig { sig_bndr = poly_id } <- id_sig
1289 = addInlinePrags poly_id (lookupPragEnv prags name)
1290 newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
1291 = newLetBndr no_gen name tau
1292
1293 -------------------
1294 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1295 tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
1296 loc matches)
1297 = tcExtendIdBinderStackForRhs [info] $
1298 tcExtendTyVarEnvForRhs mb_sig $
1299 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1300 ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
1301 matches (mkCheckExpType $ idType mono_id)
1302 ; return ( FunBind { fun_id = L loc mono_id
1303 , fun_matches = matches'
1304 , fun_co_fn = co_fn
1305 , bind_fvs = placeHolderNamesTc
1306 , fun_tick = [] } ) }
1307
1308 tcRhs (TcPatBind infos pat' grhss pat_ty)
1309 = -- When we are doing pattern bindings we *don't* bring any scoped
1310 -- type variables into scope unlike function bindings
1311 -- Wny not? They are not completely rigid.
1312 -- That's why we have the special case for a single FunBind in tcMonoBinds
1313 tcExtendIdBinderStackForRhs infos $
1314 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1315 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1316 tcGRHSsPat grhss pat_ty
1317 ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
1318 , pat_rhs_ty = pat_ty
1319 , bind_fvs = placeHolderNamesTc
1320 , pat_ticks = ([],[]) } )}
1321
1322 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
1323 tcExtendTyVarEnvForRhs Nothing thing_inside
1324 = thing_inside
1325 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1326 = tcExtendTyVarEnvFromSig sig thing_inside
1327
1328 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
1329 tcExtendTyVarEnvFromSig sig_inst thing_inside
1330 | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
1331 = tcExtendTyVarEnv2 wcs $
1332 tcExtendTyVarEnv2 skol_prs $
1333 thing_inside
1334
1335 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1336 -- Extend the TcIdBinderStack for the RHS of the binding, with
1337 -- the monomorphic Id. That way, if we have, say
1338 -- f = \x -> blah
1339 -- and something goes wrong in 'blah', we get a "relevant binding"
1340 -- looking like f :: alpha -> beta
1341 -- This applies if 'f' has a type signature too:
1342 -- f :: forall a. [a] -> [a]
1343 -- f x = True
1344 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1345 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1346 -- would not be reported as relevant, because its type is closed
1347 tcExtendIdBinderStackForRhs infos thing_inside
1348 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
1349 | MBI { mbi_mono_id = mono_id } <- infos ]
1350 thing_inside
1351 -- NotTopLevel: it's a monomorphic binding
1352
1353 ---------------------
1354 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1355 getMonoBindInfo tc_binds
1356 = foldr (get_info . unLoc) [] tc_binds
1357 where
1358 get_info (TcFunBind info _ _) rest = info : rest
1359 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1360
1361
1362 {- Note [Typechecking pattern bindings]
1363 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1364 Look at:
1365 - typecheck/should_compile/ExPat
1366 - Trac #12427, typecheck/should_compile/T12427{a,b}
1367
1368 data T where
1369 MkT :: Integral a => a -> Int -> T
1370
1371 and suppose t :: T. Which of these pattern bindings are ok?
1372
1373 E1. let { MkT p _ = t } in <body>
1374
1375 E2. let { MkT _ q = t } in <body>
1376
1377 E3. let { MkT (toInteger -> r) _ = t } in <body>
1378
1379 * (E1) is clearly wrong because the existential 'a' escapes.
1380 What type could 'p' possibly have?
1381
1382 * (E2) is fine, despite the existential pattern, because
1383 q::Int, and nothing escapes.
1384
1385 * Even (E3) is fine. The existential pattern binds a dictionary
1386 for (Integral a) which the view pattern can use to convert the
1387 a-valued field to an Integer, so r :: Integer.
1388
1389 An easy way to see all three is to imagine the desugaring.
1390 For (E2) it would look like
1391 let q = case t of MkT _ q' -> q'
1392 in <body>
1393
1394
1395 We typecheck pattern bindings as follows. First tcLhs does this:
1396
1397 1. Take each type signature q :: ty, partial or complete, and
1398 instantiate it (with tcLhsSigId) to get a MonoBindInfo. This
1399 gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
1400 a fresh name.
1401
1402 Any fresh unification variables in instiatiate(ty) born here, not
1403 deep under implications as would happen if we allocated them when
1404 we encountered q during tcPat.
1405
1406 2. Build a little environment mapping "q" -> "qm" for those Ids
1407 with signatures (inst_sig_fun)
1408
1409 3. Invoke tcLetPat to typecheck the pattern.
1410
1411 - We pass in the current TcLevel. This is captured by
1412 TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
1413 PatEnv.
1414
1415 - When tcPat finds an existential constructor, it binds fresh
1416 type variables and dictionaries as usual, increments the TcLevel,
1417 and emits an implication constraint.
1418
1419 - When we come to a binder (TcPat.tcPatBndr), it looks it up
1420 in the little environment (the pc_sig_fn field of PatCtxt).
1421
1422 Success => There was a type signature, so just use it,
1423 checking compatibility with the expected type.
1424
1425 Failure => No type sigature.
1426 Infer case: (happens only outside any constructor pattern)
1427 use a unification variable
1428 at the outer level pc_lvl
1429
1430 Check case: use promoteTcType to promote the type
1431 to the outer level pc_lvl. This is the
1432 place where we emit a constraint that'll blow
1433 up if existential capture takes place
1434
1435 Result: the type of the binder is always at pc_lvl. This is
1436 crucial.
1437
1438 4. Throughout, when we are making up an Id for the pattern-bound variables
1439 (newLetBndr), we have two cases:
1440
1441 - If we are generalising (generalisation plan is InferGen or
1442 CheckGen), then the let_bndr_spec will be LetLclBndr. In that case
1443 we want to bind a cloned, local version of the variable, with the
1444 type given by the pattern context, *not* by the signature (even if
1445 there is one; see Trac #7268). The mkExport part of the
1446 generalisation step will do the checking and impedance matching
1447 against the signature.
1448
1449 - If for some some reason we are not generalising (plan = NoGen), the
1450 LetBndrSpec will be LetGblBndr. In that case we must bind the
1451 global version of the Id, and do so with precisely the type given
1452 in the signature. (Then we unify with the type from the pattern
1453 context type.)
1454
1455
1456 And that's it! The implication constraints check for the skolem
1457 escape. It's quite simple and neat, and more expressive than before
1458 e.g. GHC 8.0 rejects (E2) and (E3).
1459
1460 Example for (E1), starting at level 1. We generate
1461 p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
1462 The (a~beta) can't float (because of the 'a'), nor be solved (because
1463 beta is untouchable.)
1464
1465 Example for (E2), we generate
1466 q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
1467 The beta is untoucable, but floats out of the constraint and can
1468 be solved absolutely fine.
1469
1470 ************************************************************************
1471 * *
1472 Generalisation
1473 * *
1474 ********************************************************************* -}
1475
1476 data GeneralisationPlan
1477 = NoGen -- No generalisation, no AbsBinds
1478
1479 | InferGen -- Implicit generalisation; there is an AbsBinds
1480 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1481
1482 | CheckGen (LHsBind Name) TcIdSigInfo
1483 -- One FunBind with a signature
1484 -- Explicit generalisation; there is an AbsBindsSig
1485
1486 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1487 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1488
1489 instance Outputable GeneralisationPlan where
1490 ppr NoGen = text "NoGen"
1491 ppr (InferGen b) = text "InferGen" <+> ppr b
1492 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1493
1494 decideGeneralisationPlan
1495 :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun
1496 -> GeneralisationPlan
1497 decideGeneralisationPlan dflags lbinds closed sig_fn
1498 | unlifted_pat_binds = NoGen
1499 | has_partial_sigs = InferGen (and partial_sig_mrs)
1500 | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
1501 | mono_local_binds closed = NoGen
1502 | otherwise = InferGen mono_restriction
1503 where
1504 binds = map unLoc lbinds
1505
1506 partial_sig_mrs :: [Bool]
1507 -- One for each parital signature (so empty => no partial sigs)
1508 -- The Bool is True if the signature has no constraint context
1509 -- so we should apply the MR
1510 -- See Note [Partial type signatures and generalisation]
1511 partial_sig_mrs
1512 = [ null theta
1513 | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
1514 <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
1515 , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
1516
1517 has_partial_sigs = not (null partial_sig_mrs)
1518 unlifted_pat_binds = any isUnliftedHsBind binds
1519 -- Unlifted patterns (unboxed tuple) must not
1520 -- be polymorphic, because we are going to force them
1521 -- See Trac #4498, #8762
1522
1523 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1524 && any restricted binds
1525
1526 mono_local_binds ClosedGroup = False
1527 mono_local_binds _ = xopt LangExt.MonoLocalBinds dflags
1528
1529 -- With OutsideIn, all nested bindings are monomorphic
1530 -- except a single function binding with a signature
1531 one_funbind_with_sig
1532 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1533 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1534 = Just (lbind, sig)
1535 | otherwise
1536 = Nothing
1537
1538 -- The Haskell 98 monomorphism restriction
1539 restricted (PatBind {}) = True
1540 restricted (VarBind { var_id = v }) = no_sig v
1541 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1542 && no_sig (unLoc v)
1543 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1544 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1545 restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"
1546
1547 restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
1548 restricted_match _ = False
1549 -- No args => like a pattern binding
1550 -- Some args => a function binding
1551
1552 no_sig n = noCompleteSig (sig_fn n)
1553
1554 isClosedBndrGroup :: Bag (LHsBind Name) -> TcM IsGroupClosed
1555 isClosedBndrGroup binds = do
1556 type_env <- getLclTypeEnv
1557 if foldUFM (is_closed_ns type_env) True fv_env
1558 then return ClosedGroup
1559 else return $ NonClosedGroup fv_env
1560 where
1561 fv_env :: NameEnv NameSet
1562 fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
1563
1564 bindFvs :: HsBindLR Name idR -> [(Name, NameSet)]
1565 bindFvs (FunBind { fun_id = f, bind_fvs = fvs })
1566 = [(unLoc f, fvs)]
1567 bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
1568 = [(b, fvs) | b <- collectPatBinders pat]
1569 bindFvs _
1570 = []
1571
1572 is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
1573 is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns
1574 -- ns are the Names referred to from the RHS of this bind
1575
1576 is_closed_id :: TcTypeEnv -> Name -> Bool
1577 -- See Note [Bindings with closed types] in TcRnTypes
1578 is_closed_id type_env name
1579 | Just thing <- lookupNameEnv type_env name
1580 = case thing of
1581 ATcId { tct_info = ClosedLet } -> True -- This is the key line
1582 ATcId {} -> False
1583 ATyVar {} -> False -- In-scope type variables
1584 AGlobal {} -> True -- are not closed!
1585 _ -> pprPanic "is_closed_id" (ppr name)
1586 | otherwise
1587 = True
1588 -- The free-var set for a top level binding mentions
1589 -- imported things too, so that we can report unused imports
1590 -- These won't be in the local type env.
1591 -- Ditto class method etc from the current module
1592
1593 -------------------
1594 checkStrictBinds :: TopLevelFlag -> RecFlag
1595 -> [LHsBind Name]
1596 -> LHsBinds TcId -> [Id]
1597 -> TcM ()
1598 -- Check that non-overloaded unlifted bindings are
1599 -- a) non-recursive,
1600 -- b) not top level,
1601 -- c) not a multiple-binding group (more or less implied by (a))
1602
1603 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1604 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
1605 = do { check (isNotTopLevel top_lvl)
1606 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
1607 ; check (isNonRec rec_group)
1608 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
1609
1610 ; check (all is_monomorphic (bagToList tc_binds))
1611 (polyBindErr orig_binds)
1612 -- data Ptr a = Ptr Addr#
1613 -- f x = let p@(Ptr y) = ... in ...
1614 -- Here the binding for 'p' is polymorphic, but does
1615 -- not mix with an unlifted binding for 'y'. You should
1616 -- use a bang pattern. Trac #6078.
1617
1618 ; check (isSingleton orig_binds)
1619 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
1620
1621 -- Complain about a binding that looks lazy
1622 -- e.g. let I# y = x in ...
1623 -- Remember, in checkStrictBinds we are going to do strict
1624 -- matching, so (for software engineering reasons) we insist
1625 -- that the strictness is manifest on each binding
1626 -- However, lone (unboxed) variables are ok
1627 ; check (not any_pat_looks_lazy)
1628 (unliftedMustBeBang orig_binds) }
1629 | otherwise
1630 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
1631 return ()
1632 where
1633 any_unlifted_bndr = any is_unlifted poly_ids
1634 any_strict_pat = any (isUnliftedHsBind . unLoc) orig_binds
1635 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1636
1637 is_unlifted id = case tcSplitSigmaTy (idType id) of
1638 (_, _, rho) -> isUnliftedType rho
1639 -- For the is_unlifted check, we need to look inside polymorphism
1640 -- and overloading. E.g. x = (# 1, True #)
1641 -- would get type forall a. Num a => (# a, Bool #)
1642 -- and we want to reject that. See Trac #9140
1643
1644 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1645 = null tvs && null evs
1646 is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }))
1647 = null tvs && null evs
1648 is_monomorphic _ = True
1649
1650 check :: Bool -> MsgDoc -> TcM ()
1651 -- Just like checkTc, but with a special case for module GHC.Prim:
1652 -- see Note [Compiling GHC.Prim]
1653 check True _ = return ()
1654 check False err = do { mod <- getModule
1655 ; checkTc (mod == gHC_PRIM) err }
1656
1657 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1658 unliftedMustBeBang binds
1659 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1660 2 (vcat (map ppr binds))
1661
1662 polyBindErr :: [LHsBind Name] -> SDoc
1663 polyBindErr binds
1664 = hang (text "You can't mix polymorphic and unlifted bindings")
1665 2 (vcat [vcat (map ppr binds),
1666 text "Probable fix: add a type signature"])
1667
1668 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1669 strictBindErr flavour any_unlifted_bndr binds
1670 = hang (text flavour <+> msg <+> text "aren't allowed:")
1671 2 (vcat (map ppr binds))
1672 where
1673 msg | any_unlifted_bndr = text "bindings for unlifted types"
1674 | otherwise = text "bang-pattern or unboxed-tuple bindings"
1675
1676
1677 {- Note [Compiling GHC.Prim]
1678 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1679 Module GHC.Prim has no source code: it is the host module for
1680 primitive, built-in functions and types. However, for Haddock-ing
1681 purposes we generate (via utils/genprimopcode) a fake source file
1682 GHC/Prim.hs, and give it to Haddock, so that it can generate
1683 documentation. It contains definitions like
1684 nullAddr# :: NullAddr#
1685 which would normally be rejected as a top-level unlifted binding. But
1686 we don't want to complain, because we are only "compiling" this fake
1687 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
1688 in checkStrictBinds.
1689
1690 (We only make the test if things look wrong, so there is no cost in
1691 the common case.) -}
1692
1693
1694 {- *********************************************************************
1695 * *
1696 Error contexts and messages
1697 * *
1698 ********************************************************************* -}
1699
1700 -- This one is called on LHS, when pat and grhss are both Name
1701 -- and on RHS, when pat is TcId and grhss is still Name
1702 patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)
1703 => LPat id -> GRHSs Name body -> SDoc
1704 patMonoBindsCtxt pat grhss
1705 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
1706