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