Typos in comments only [ci skip]
[ghc.git] / compiler / typecheck / TcExpr.hs
1 {-
2 %
3 (c) The University of Glasgow 2006
4 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5
6 \section[TcExpr]{Typecheck an expression}
7 -}
8
9 {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
10 {-# LANGUAGE FlexibleContexts #-}
11
12 module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
13 tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
14 tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
15 tcCheckId,
16 addExprErrCtxt,
17 getFixedTyVars ) where
18
19 #include "HsVersions.h"
20
21 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
22 import THNames( liftStringName, liftName )
23
24 import HsSyn
25 import TcHsSyn
26 import TcRnMonad
27 import TcUnify
28 import BasicTypes
29 import Inst
30 import TcBinds ( chooseInferredQuantifiers, tcLocalBinds )
31 import TcSigs ( tcUserTypeSig, tcInstSig )
32 import TcSimplify ( simplifyInfer, InferMode(..) )
33 import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
34 import FamInstEnv ( FamInstEnvs )
35 import RnEnv ( addUsedGRE, addNameClashErrRn
36 , unknownSubordinateErr )
37 import TcEnv
38 import TcArrows
39 import TcMatches
40 import TcHsType
41 import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
42 import TcPat
43 import TcMType
44 import TcType
45 import DsMonad
46 import Id
47 import IdInfo
48 import ConLike
49 import DataCon
50 import PatSyn
51 import Name
52 import NameEnv
53 import NameSet
54 import RdrName
55 import TyCon
56 import Type
57 import TcEvidence
58 import VarSet
59 import TysWiredIn
60 import TysPrim( intPrimTy )
61 import PrimOp( tagToEnumKey )
62 import PrelNames
63 import MkId ( proxyHashId )
64 import DynFlags
65 import SrcLoc
66 import Util
67 import VarEnv ( emptyTidyEnv )
68 import ListSetOps
69 import Maybes
70 import Outputable
71 import FastString
72 import Control.Monad
73 import Class(classTyCon)
74 import UniqFM ( nonDetEltsUFM )
75 import qualified GHC.LanguageExtensions as LangExt
76
77 import Data.Function
78 import Data.List
79 import Data.Either
80 import qualified Data.Set as Set
81
82 {-
83 ************************************************************************
84 * *
85 \subsection{Main wrappers}
86 * *
87 ************************************************************************
88 -}
89
90 tcPolyExpr, tcPolyExprNC
91 :: LHsExpr Name -- Expression to type check
92 -> TcSigmaType -- Expected type (could be a polytype)
93 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
94
95 -- tcPolyExpr is a convenient place (frequent but not too frequent)
96 -- place to add context information.
97 -- The NC version does not do so, usually because the caller wants
98 -- to do so himself.
99
100 tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)
101 tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)
102
103 -- these versions take an ExpType
104 tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId)
105 tc_poly_expr expr res_ty
106 = addExprErrCtxt expr $
107 do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
108
109 tc_poly_expr_nc (L loc expr) res_ty
110 = do { traceTc "tcPolyExprNC" (ppr res_ty)
111 ; (wrap, expr')
112 <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
113 setSrcSpan loc $
114 -- NB: setSrcSpan *after* skolemising, so we get better
115 -- skolem locations
116 tcExpr expr res_ty
117 ; return $ L loc (mkHsWrap wrap expr') }
118
119 ---------------
120 tcMonoExpr, tcMonoExprNC
121 :: LHsExpr Name -- Expression to type check
122 -> ExpRhoType -- Expected type
123 -- Definitely no foralls at the top
124 -> TcM (LHsExpr TcId)
125
126 tcMonoExpr expr res_ty
127 = addErrCtxt (exprCtxt expr) $
128 tcMonoExprNC expr res_ty
129
130 tcMonoExprNC (L loc expr) res_ty
131 = setSrcSpan loc $
132 do { expr' <- tcExpr expr res_ty
133 ; return (L loc expr') }
134
135 ---------------
136 tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM ( LHsExpr TcId
137 , TcSigmaType )
138 -- Infer a *sigma*-type.
139 tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)
140
141 tcInferSigmaNC (L loc expr)
142 = setSrcSpan loc $
143 do { (expr', sigma) <- tcInferNoInst (tcExpr expr)
144 ; return (L loc expr', sigma) }
145
146 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
147 -- Infer a *rho*-type. The return type is always (shallowly) instantiated.
148 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
149
150 tcInferRhoNC expr
151 = do { (expr', sigma) <- tcInferSigmaNC expr
152 ; (wrap, rho) <- topInstantiate (exprCtOrigin (unLoc expr)) sigma
153 ; return (mkLHsWrap wrap expr', rho) }
154
155
156 {-
157 ************************************************************************
158 * *
159 tcExpr: the main expression typechecker
160 * *
161 ************************************************************************
162
163 NB: The res_ty is always deeply skolemised.
164 -}
165
166 tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
167 tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
168 tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty
169
170 tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty
171 tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
172
173 tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit
174 ; tcWrapResult e (HsLit lit) lit_ty res_ty }
175
176 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
177 ; return (HsPar expr') }
178
179 tcExpr (HsSCC src lbl expr) res_ty
180 = do { expr' <- tcMonoExpr expr res_ty
181 ; return (HsSCC src lbl expr') }
182
183 tcExpr (HsTickPragma src info srcInfo expr) res_ty
184 = do { expr' <- tcMonoExpr expr res_ty
185 ; return (HsTickPragma src info srcInfo expr') }
186
187 tcExpr (HsCoreAnn src lbl expr) res_ty
188 = do { expr' <- tcMonoExpr expr res_ty
189 ; return (HsCoreAnn src lbl expr') }
190
191 tcExpr (HsOverLit lit) res_ty
192 = do { lit' <- newOverloadedLit lit res_ty
193 ; return (HsOverLit lit') }
194
195 tcExpr (NegApp expr neg_expr) res_ty
196 = do { (expr', neg_expr')
197 <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
198 \[arg_ty] ->
199 tcMonoExpr expr (mkCheckExpType arg_ty)
200 ; return (NegApp expr' neg_expr') }
201
202 tcExpr e@(HsIPVar x) res_ty
203 = do { {- Implicit parameters must have a *tau-type* not a
204 type scheme. We enforce this by creating a fresh
205 type variable as its type. (Because res_ty may not
206 be a tau-type.) -}
207 ip_ty <- newOpenFlexiTyVarTy
208 ; let ip_name = mkStrLitTy (hsIPNameFS x)
209 ; ipClass <- tcLookupClass ipClassName
210 ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
211 ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
212 ip_ty res_ty }
213 where
214 -- Coerces a dictionary for `IP "x" t` into `t`.
215 fromDict ipClass x ty = HsWrap $ mkWpCastR $
216 unwrapIP $ mkClassPred ipClass [x,ty]
217 origin = IPOccOrigin x
218
219 tcExpr e@(HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels]
220 = do { isLabelClass <- tcLookupClass isLabelClassName
221 ; alpha <- newOpenFlexiTyVarTy
222 ; let lbl = mkStrLitTy l
223 pred = mkClassPred isLabelClass [lbl, alpha]
224 ; loc <- getSrcSpanM
225 ; var <- emitWantedEvVar origin pred
226 ; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
227 (HsVar (L loc proxyHashId)))
228 tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg
229 ; tcWrapResult e tm alpha res_ty }
230 where
231 -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`.
232 fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred
233 origin = OverLabelOrigin l
234
235 tcExpr (HsLam match) res_ty
236 = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
237 ; return (mkHsWrap wrap (HsLam match')) }
238 where
239 match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
240 herald = sep [ text "The lambda expression" <+>
241 quotes (pprSetDepth (PartWay 1) $
242 pprMatches match),
243 -- The pprSetDepth makes the abstraction print briefly
244 text "has"]
245
246 tcExpr e@(HsLamCase matches) res_ty
247 = do { (matches', wrap)
248 <- tcMatchLambda msg match_ctxt matches res_ty
249 -- The laziness annotation is because we don't want to fail here
250 -- if there are multiple arguments
251 ; return (mkHsWrap wrap $ HsLamCase matches') }
252 where
253 msg = sep [ text "The function" <+> quotes (ppr e)
254 , text "requires"]
255 match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
256
257 tcExpr e@(ExprWithTySig expr sig_ty) res_ty
258 = do { let loc = getLoc (hsSigWcType sig_ty)
259 ; sig_info <- checkNoErrs $ -- Avoid error cascade
260 tcUserTypeSig loc sig_ty Nothing
261 ; (expr', poly_ty) <- tcExprSig expr sig_info
262 ; let expr'' = ExprWithTySigOut expr' sig_ty
263 ; tcWrapResult e expr'' poly_ty res_ty }
264
265 {-
266 Note [Type-checking overloaded labels]
267 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
268 Recall that (in GHC.OverloadedLabels) we have
269
270 class IsLabel (x :: Symbol) a where
271 fromLabel :: Proxy# x -> a
272
273 When we see an overloaded label like `#foo`, we generate a fresh
274 variable `alpha` for the type and emit an `IsLabel "foo" alpha`
275 constraint. Because the `IsLabel` class has a single method, it is
276 represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
277 `Proxy# "foo" -> alpha` (just like for implicit parameters). We then
278 apply it to `proxy#` of type `Proxy# "foo"`.
279
280 That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
281 -}
282
283
284 {-
285 ************************************************************************
286 * *
287 Infix operators and sections
288 * *
289 ************************************************************************
290
291 Note [Left sections]
292 ~~~~~~~~~~~~~~~~~~~~
293 Left sections, like (4 *), are equivalent to
294 \ x -> (*) 4 x,
295 or, if PostfixOperators is enabled, just
296 (*) 4
297 With PostfixOperators we don't actually require the function to take
298 two arguments at all. For example, (x `not`) means (not x); you get
299 postfix operators! Not Haskell 98, but it's less work and kind of
300 useful.
301
302 Note [Typing rule for ($)]
303 ~~~~~~~~~~~~~~~~~~~~~~~~~~
304 People write
305 runST $ blah
306 so much, where
307 runST :: (forall s. ST s a) -> a
308 that I have finally given in and written a special type-checking
309 rule just for saturated applications of ($).
310 * Infer the type of the first argument
311 * Decompose it; should be of form (arg2_ty -> res_ty),
312 where arg2_ty might be a polytype
313 * Use arg2_ty to typecheck arg2
314
315 Note [Typing rule for seq]
316 ~~~~~~~~~~~~~~~~~~~~~~~~~~
317 We want to allow
318 x `seq` (# p,q #)
319 which suggests this type for seq:
320 seq :: forall (a:*) (b:Open). a -> b -> b,
321 with (b:Open) meaning that be can be instantiated with an unboxed
322 tuple. The trouble is that this might accept a partially-applied
323 'seq', and I'm just not certain that would work. I'm only sure it's
324 only going to work when it's fully applied, so it turns into
325 case x of _ -> (# p,q #)
326
327 So it seems more uniform to treat 'seq' as it it was a language
328 construct.
329
330 See also Note [seqId magic] in MkId
331 -}
332
333 tcExpr expr@(OpApp arg1 op fix arg2) res_ty
334 | (L loc (HsVar (L lv op_name))) <- op
335 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
336 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
337 ; let arg2_exp_ty = res_ty
338 ; arg1' <- tcArg op arg1 arg1_ty 1
339 ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
340 tc_poly_expr_nc arg2 arg2_exp_ty
341 ; arg2_ty <- readExpType arg2_exp_ty
342 ; op_id <- tcLookupId op_name
343 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty])
344 (HsVar (L lv op_id)))
345 ; return $ OpApp arg1' op' fix arg2' }
346
347 | (L loc (HsVar (L lv op_name))) <- op
348 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
349 = do { traceTc "Application rule" (ppr op)
350 ; (arg1', arg1_ty) <- tcInferSigma arg1
351
352 ; let doc = text "The first argument of ($) takes"
353 orig1 = exprCtOrigin (unLoc arg1)
354 ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
355 matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
356
357 -- We have (arg1 $ arg2)
358 -- So: arg1_ty = arg2_ty -> op_res_ty
359 -- where arg2_sigma maybe polymorphic; that's the point
360
361 ; arg2' <- tcArg op arg2 arg2_sigma 2
362
363 -- Make sure that the argument type has kind '*'
364 -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
365 -- Eg we do not want to allow (D# $ 4.0#) Trac #5570
366 -- (which gives a seg fault)
367 --
368 -- The *result* type can have any kind (Trac #8739),
369 -- so we don't need to check anything for that
370 ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind
371 -- ignore the evidence. arg2_sigma must have type * or #,
372 -- because we know arg2_sigma -> or_res_ty is well-kinded
373 -- (because otherwise matchActualFunTys would fail)
374 -- There's no possibility here of, say, a kind family reducing to *.
375
376 ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
377 -- op_res -> res
378
379 ; op_id <- tcLookupId op_name
380 ; res_ty <- readExpType res_ty
381 ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
382 , arg2_sigma
383 , res_ty])
384 (HsVar (L lv op_id)))
385 -- arg1' :: arg1_ty
386 -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
387 -- wrap_res :: op_res_ty "->" res_ty
388 -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
389
390 -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
391 wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty
392 <.> wrap_arg1
393
394 ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
395
396 | (L loc (HsRecFld (Ambiguous lbl _))) <- op
397 , Just sig_ty <- obviousSig (unLoc arg1)
398 -- See Note [Disambiguating record fields]
399 = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
400 ; sel_name <- disambiguateSelector lbl sig_tc_ty
401 ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
402 ; tcExpr (OpApp arg1 op' fix arg2) res_ty
403 }
404
405 | otherwise
406 = do { traceTc "Non Application rule" (ppr op)
407 ; (wrap, op', [Left arg1', Left arg2'])
408 <- tcApp (Just $ mk_op_msg op)
409 op [Left arg1, Left arg2] res_ty
410 ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
411
412 -- Right sections, equivalent to \ x -> x `op` expr, or
413 -- \ x -> op x expr
414
415 tcExpr expr@(SectionR op arg2) res_ty
416 = do { (op', op_ty) <- tcInferFun op
417 ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
418 matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) 2 op_ty
419 ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
420 (mkFunTy arg1_ty op_res_ty) res_ty
421 ; arg2' <- tcArg op arg2 arg2_ty 2
422 ; return ( mkHsWrap wrap_res $
423 SectionR (mkLHsWrap wrap_fun op') arg2' ) }
424
425 tcExpr expr@(SectionL arg1 op) res_ty
426 = do { (op', op_ty) <- tcInferFun op
427 ; dflags <- getDynFlags -- Note [Left sections]
428 ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
429 | otherwise = 2
430
431 ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
432 <- matchActualFunTys (mk_op_msg op) SectionOrigin (Just op)
433 n_reqd_args op_ty
434 ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
435 (mkFunTys arg_tys op_res_ty) res_ty
436 ; arg1' <- tcArg op arg1 arg1_ty 1
437 ; return ( mkHsWrap wrap_res $
438 SectionL arg1' (mkLHsWrap wrap_fn op') ) }
439
440 tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
441 | all tupArgPresent tup_args
442 = do { let arity = length tup_args
443 tup_tc = tupleTyCon boxity arity
444 ; res_ty <- expTypeToType res_ty
445 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
446 -- Unboxed tuples have RuntimeRep vars, which we
447 -- don't care about here
448 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
449 ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
450 Boxed -> arg_tys
451 ; tup_args1 <- tcTupArgs tup_args arg_tys'
452 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
453
454 | otherwise
455 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
456 do { let arity = length tup_args
457
458 ; arg_tys <- case boxity of
459 { Boxed -> newFlexiTyVarTys arity liftedTypeKind
460 ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
461 ; let actual_res_ty
462 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
463 (mkTupleTy boxity arg_tys)
464
465 ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
466 (Just expr)
467 actual_res_ty res_ty
468
469 -- Handle tuple sections where
470 ; tup_args1 <- tcTupArgs tup_args arg_tys
471
472 ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
473
474 tcExpr (ExplicitSum alt arity expr _) res_ty
475 = do { let sum_tc = sumTyCon arity
476 ; res_ty <- expTypeToType res_ty
477 ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
478 ; -- Drop levity vars, we don't care about them here
479 let arg_tys' = drop arity arg_tys
480 ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))
481 ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') }
482
483 tcExpr (ExplicitList _ witness exprs) res_ty
484 = case witness of
485 Nothing -> do { res_ty <- expTypeToType res_ty
486 ; (coi, elt_ty) <- matchExpectedListTy res_ty
487 ; exprs' <- mapM (tc_elt elt_ty) exprs
488 ; return $
489 mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
490
491 Just fln -> do { ((exprs', elt_ty), fln')
492 <- tcSyntaxOp ListOrigin fln
493 [synKnownType intTy, SynList] res_ty $
494 \ [elt_ty] ->
495 do { exprs' <-
496 mapM (tc_elt elt_ty) exprs
497 ; return (exprs', elt_ty) }
498
499 ; return $ ExplicitList elt_ty (Just fln') exprs' }
500 where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
501
502 tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
503 = do { res_ty <- expTypeToType res_ty
504 ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
505 ; exprs' <- mapM (tc_elt elt_ty) exprs
506 ; return $
507 mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }
508 where
509 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
510
511 {-
512 ************************************************************************
513 * *
514 Let, case, if, do
515 * *
516 ************************************************************************
517 -}
518
519 tcExpr (HsLet (L l binds) expr) res_ty
520 = do { (binds', expr') <- tcLocalBinds binds $
521 tcMonoExpr expr res_ty
522 ; return (HsLet (L l binds') expr') }
523
524 tcExpr (HsCase scrut matches) res_ty
525 = do { -- We used to typecheck the case alternatives first.
526 -- The case patterns tend to give good type info to use
527 -- when typechecking the scrutinee. For example
528 -- case (map f) of
529 -- (x:xs) -> ...
530 -- will report that map is applied to too few arguments
531 --
532 -- But now, in the GADT world, we need to typecheck the scrutinee
533 -- first, to get type info that may be refined in the case alternatives
534 (scrut', scrut_ty) <- tcInferRho scrut
535
536 ; traceTc "HsCase" (ppr scrut_ty)
537 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
538 ; return (HsCase scrut' matches') }
539 where
540 match_ctxt = MC { mc_what = CaseAlt,
541 mc_body = tcBody }
542
543 tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
544 = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
545 ; res_ty <- tauifyExpType res_ty
546 -- Just like Note [Case branches must never infer a non-tau type]
547 -- in TcMatches (See #10619)
548
549 ; b1' <- tcMonoExpr b1 res_ty
550 ; b2' <- tcMonoExpr b2 res_ty
551 ; return (HsIf Nothing pred' b1' b2') }
552
553 tcExpr (HsIf (Just fun) pred b1 b2) res_ty
554 = do { ((pred', b1', b2'), fun')
555 <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
556 \ [pred_ty, b1_ty, b2_ty] ->
557 do { pred' <- tcPolyExpr pred pred_ty
558 ; b1' <- tcPolyExpr b1 b1_ty
559 ; b2' <- tcPolyExpr b2 b2_ty
560 ; return (pred', b1', b2') }
561 ; return (HsIf (Just fun') pred' b1' b2') }
562
563 tcExpr (HsMultiIf _ alts) res_ty
564 = do { res_ty <- if isSingleton alts
565 then return res_ty
566 else tauifyExpType res_ty
567 -- Just like TcMatches
568 -- Note [Case branches must never infer a non-tau type]
569
570 ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
571 ; res_ty <- readExpType res_ty
572 ; return (HsMultiIf res_ty alts') }
573 where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
574
575 tcExpr (HsDo do_or_lc stmts _) res_ty
576 = do { expr' <- tcDoStmts do_or_lc stmts res_ty
577 ; return expr' }
578
579 tcExpr (HsProc pat cmd) res_ty
580 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
581 ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
582
583 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
584 -- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
585 tcExpr (HsStatic fvs expr) res_ty
586 = do { res_ty <- expTypeToType res_ty
587 ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
588 ; (expr', lie) <- captureConstraints $
589 addErrCtxt (hang (text "In the body of a static form:")
590 2 (ppr expr)
591 ) $
592 tcPolyExprNC expr expr_ty
593 -- Check that the free variables of the static form are closed.
594 -- It's OK to use nonDetEltsUFM here as the only side effects of
595 -- checkClosedInStaticForm are error messages.
596 ; mapM_ checkClosedInStaticForm $ nonDetEltsUFM fvs
597
598 -- Require the type of the argument to be Typeable.
599 -- The evidence is not used, but asking the constraint ensures that
600 -- the current implementation is as restrictive as future versions
601 -- of the StaticPointers extension.
602 ; typeableClass <- tcLookupClass typeableClassName
603 ; _ <- emitWantedEvVar StaticOrigin $
604 mkTyConApp (classTyCon typeableClass)
605 [liftedTypeKind, expr_ty]
606 -- Insert the constraints of the static form in a global list for later
607 -- validation.
608 ; emitStaticConstraints lie
609
610 -- Wrap the static form with the 'fromStaticPtr' call.
611 ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
612 ; let wrap = mkWpTyApps [expr_ty]
613 ; loc <- getSrcSpanM
614 ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr)
615 (L loc (HsStatic fvs expr'))
616 }
617
618 {-
619 ************************************************************************
620 * *
621 Record construction and update
622 * *
623 ************************************************************************
624 -}
625
626 tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
627 , rcon_flds = rbinds }) res_ty
628 = do { con_like <- tcLookupConLike con_name
629
630 -- Check for missing fields
631 ; checkMissingFields con_like rbinds
632
633 ; (con_expr, con_sigma) <- tcInferId con_name
634 ; (con_wrap, con_tau) <-
635 topInstantiate (OccurrenceOf con_name) con_sigma
636 -- a shallow instantiation should really be enough for
637 -- a data constructor.
638 ; let arity = conLikeArity con_like
639 Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
640 ; case conLikeWrapId_maybe con_like of
641 Nothing -> nonBidirectionalErr (conLikeName con_like)
642 Just con_id -> do {
643 res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")
644 (Just expr) actual_res_ty res_ty
645 ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
646 ; return $
647 mkHsWrap res_wrap $
648 RecordCon { rcon_con_name = L loc con_id
649 , rcon_con_expr = mkHsWrap con_wrap con_expr
650 , rcon_con_like = con_like
651 , rcon_flds = rbinds' } } }
652
653 {-
654 Note [Type of a record update]
655 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
656 The main complication with RecordUpd is that we need to explicitly
657 handle the *non-updated* fields. Consider:
658
659 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
660 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
661 | MkT3 { fd :: a }
662
663 upd :: T a b c -> (b',c) -> T a b' c
664 upd t x = t { fb = x}
665
666 The result type should be (T a b' c)
667 not (T a b c), because 'b' *is not* mentioned in a non-updated field
668 not (T a b' c'), because 'c' *is* mentioned in a non-updated field
669 NB that it's not good enough to look at just one constructor; we must
670 look at them all; cf Trac #3219
671
672 After all, upd should be equivalent to:
673 upd t x = case t of
674 MkT1 p q -> MkT1 p x
675 MkT2 a b -> MkT2 p b
676 MkT3 d -> error ...
677
678 So we need to give a completely fresh type to the result record,
679 and then constrain it by the fields that are *not* updated ("p" above).
680 We call these the "fixed" type variables, and compute them in getFixedTyVars.
681
682 Note that because MkT3 doesn't contain all the fields being updated,
683 its RHS is simply an error, so it doesn't impose any type constraints.
684 Hence the use of 'relevant_cont'.
685
686 Note [Implicit type sharing]
687 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
688 We also take into account any "implicit" non-update fields. For example
689 data T a b where { MkT { f::a } :: T a a; ... }
690 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
691
692 Then consider
693 upd t x = t { f=x }
694 We infer the type
695 upd :: T a b -> a -> T a b
696 upd (t::T a b) (x::a)
697 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
698 We can't give it the more general type
699 upd :: T a b -> c -> T c b
700
701 Note [Criteria for update]
702 ~~~~~~~~~~~~~~~~~~~~~~~~~~
703 We want to allow update for existentials etc, provided the updated
704 field isn't part of the existential. For example, this should be ok.
705 data T a where { MkT { f1::a, f2::b->b } :: T a }
706 f :: T a -> b -> T b
707 f t b = t { f1=b }
708
709 The criterion we use is this:
710
711 The types of the updated fields
712 mention only the universally-quantified type variables
713 of the data constructor
714
715 NB: this is not (quite) the same as being a "naughty" record selector
716 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
717 in the case of GADTs. Consider
718 data T a where { MkT :: { f :: a } :: T [a] }
719 Then f is not "naughty" because it has a well-typed record selector.
720 But we don't allow updates for 'f'. (One could consider trying to
721 allow this, but it makes my head hurt. Badly. And no one has asked
722 for it.)
723
724 In principle one could go further, and allow
725 g :: T a -> T a
726 g t = t { f2 = \x -> x }
727 because the expression is polymorphic...but that seems a bridge too far.
728
729 Note [Data family example]
730 ~~~~~~~~~~~~~~~~~~~~~~~~~~
731 data instance T (a,b) = MkT { x::a, y::b }
732 --->
733 data :TP a b = MkT { a::a, y::b }
734 coTP a b :: T (a,b) ~ :TP a b
735
736 Suppose r :: T (t1,t2), e :: t3
737 Then r { x=e } :: T (t3,t1)
738 --->
739 case r |> co1 of
740 MkT x y -> MkT e y |> co2
741 where co1 :: T (t1,t2) ~ :TP t1 t2
742 co2 :: :TP t3 t2 ~ T (t3,t2)
743 The wrapping with co2 is done by the constructor wrapper for MkT
744
745 Outgoing invariants
746 ~~~~~~~~~~~~~~~~~~~
747 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
748
749 * cons are the data constructors to be updated
750
751 * in_inst_tys, out_inst_tys have same length, and instantiate the
752 *representation* tycon of the data cons. In Note [Data
753 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
754
755 Note [Mixed Record Field Updates]
756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
757 Consider the following pattern synonym.
758
759 data MyRec = MyRec { foo :: Int, qux :: String }
760
761 pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
762
763 This allows updates such as the following
764
765 updater :: MyRec -> MyRec
766 updater a = a {f1 = 1 }
767
768 It would also make sense to allow the following update (which we reject).
769
770 updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
771
772 This leads to confusing behaviour when the selectors in fact refer the same
773 field.
774
775 updater a = a {f1 = 1, foo = 2} ==? ???
776
777 For this reason, we reject a mixture of pattern synonym and normal record
778 selectors in the same update block. Although of course we still allow the
779 following.
780
781 updater a = (a {f1 = 1}) {foo = 2}
782
783 > updater (MyRec 0 "str")
784 MyRec 2 "str"
785
786 -}
787
788 tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
789 = ASSERT( notNull rbnds )
790 do { -- STEP -2: typecheck the record_expr, the record to be updated
791 (record_expr', record_rho) <- tcInferRho record_expr
792
793 -- STEP -1 See Note [Disambiguating record fields]
794 -- After this we know that rbinds is unambiguous
795 ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
796 ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
797 upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
798 sel_ids = map selectorAmbiguousFieldOcc upd_flds
799 -- STEP 0
800 -- Check that the field names are really field names
801 -- and they are all field names for proper records or
802 -- all field names for pattern synonyms.
803 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
804 | fld <- rbinds,
805 -- Excludes class ops
806 let L loc sel_id = hsRecUpdFieldId (unLoc fld),
807 not (isRecordSelector sel_id),
808 let fld_name = idName sel_id ]
809 ; unless (null bad_guys) (sequence bad_guys >> failM)
810 -- See note [Mixed Record Selectors]
811 ; let (data_sels, pat_syn_sels) =
812 partition isDataConRecordSelector sel_ids
813 ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
814 ; checkTc ( null data_sels || null pat_syn_sels )
815 ( mixedSelectors data_sels pat_syn_sels )
816
817 -- STEP 1
818 -- Figure out the tycon and data cons from the first field name
819 ; let -- It's OK to use the non-tc splitters here (for a selector)
820 sel_id : _ = sel_ids
821
822 mtycon :: Maybe TyCon
823 mtycon = case idDetails sel_id of
824 RecSelId (RecSelData tycon) _ -> Just tycon
825 _ -> Nothing
826
827 con_likes :: [ConLike]
828 con_likes = case idDetails sel_id of
829 RecSelId (RecSelData tc) _
830 -> map RealDataCon (tyConDataCons tc)
831 RecSelId (RecSelPatSyn ps) _
832 -> [PatSynCon ps]
833 _ -> panic "tcRecordUpd"
834 -- NB: for a data type family, the tycon is the instance tycon
835
836 relevant_cons = conLikesWithFields con_likes upd_fld_occs
837 -- A constructor is only relevant to this process if
838 -- it contains *all* the fields that are being updated
839 -- Other ones will cause a runtime error if they occur
840
841 -- Step 2
842 -- Check that at least one constructor has all the named fields
843 -- i.e. has an empty set of bad fields returned by badFields
844 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
845
846 -- Take apart a representative constructor
847 ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
848 (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _)
849 = conLikeFullSig con1
850 con1_flds = map flLabel $ conLikeFieldLabels con1
851 con1_tv_tys = mkTyVarTys con1_tvs
852 con1_res_ty = case mtycon of
853 Just tc -> mkFamilyTyConApp tc con1_tv_tys
854 Nothing -> conLikeResTy con1 con1_tv_tys
855
856 -- Check that we're not dealing with a unidirectional pattern
857 -- synonym
858 ; unless (isJust $ conLikeWrapId_maybe con1)
859 (nonBidirectionalErr (conLikeName con1))
860
861 -- STEP 3 Note [Criteria for update]
862 -- Check that each updated field is polymorphic; that is, its type
863 -- mentions only the universally-quantified variables of the data con
864 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
865 bad_upd_flds = filter bad_fld flds1_w_tys
866 con1_tv_set = mkVarSet con1_tvs
867 bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
868 not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
869 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
870
871 -- STEP 4 Note [Type of a record update]
872 -- Figure out types for the scrutinee and result
873 -- Both are of form (T a b c), with fresh type variables, but with
874 -- common variables where the scrutinee and result must have the same type
875 -- These are variables that appear in *any* arg of *any* of the
876 -- relevant constructors *except* in the updated fields
877 --
878 ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
879 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
880
881 mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
882 -- Deals with instantiation of kind variables
883 -- c.f. TcMType.newMetaTyVars
884 mk_inst_ty subst (tv, result_inst_ty)
885 | is_fixed_tv tv -- Same as result type
886 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
887 | otherwise -- Fresh type, of correct kind
888 = do { (subst', new_tv) <- newMetaTyVarX subst tv
889 ; return (subst', mkTyVarTy new_tv) }
890
891 ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
892 ; let result_inst_tys = mkTyVarTys con1_tvs'
893 init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
894
895 ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
896 (con1_tvs `zip` result_inst_tys)
897
898 ; let rec_res_ty = TcType.substTy result_subst con1_res_ty
899 scrut_ty = TcType.substTy scrut_subst con1_res_ty
900 con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
901
902 ; wrap_res <- tcSubTypeHR (exprCtOrigin expr)
903 (Just expr) rec_res_ty res_ty
904 ; co_scrut <- unifyType (Just record_expr) record_rho scrut_ty
905 -- NB: normal unification is OK here (as opposed to subsumption),
906 -- because for this to work out, both record_rho and scrut_ty have
907 -- to be normal datatypes -- no contravariant stuff can go on
908
909 -- STEP 5
910 -- Typecheck the bindings
911 ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds
912
913 -- STEP 6: Deal with the stupid theta
914 ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)
915 ; instStupidTheta RecordUpdOrigin theta'
916
917 -- Step 7: make a cast for the scrutinee, in the
918 -- case that it's from a data family
919 ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty
920 fam_co | Just tycon <- mtycon
921 , Just co_con <- tyConFamilyCoercion_maybe tycon
922 = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])
923 | otherwise
924 = idHsWrapper
925
926 -- Step 8: Check that the req constraints are satisfied
927 -- For normal data constructors req_theta is empty but we must do
928 -- this check for pattern synonyms.
929 ; let req_theta' = substThetaUnchecked scrut_subst req_theta
930 ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
931
932 -- Phew!
933 ; return $
934 mkHsWrap wrap_res $
935 RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
936 , rupd_flds = rbinds'
937 , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys
938 , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }
939
940 tcExpr (HsRecFld f) res_ty
941 = tcCheckRecSelId f res_ty
942
943 {-
944 ************************************************************************
945 * *
946 Arithmetic sequences e.g. [a,b..]
947 and their parallel-array counterparts e.g. [: a,b.. :]
948
949 * *
950 ************************************************************************
951 -}
952
953 tcExpr (ArithSeq _ witness seq) res_ty
954 = tcArithSeq witness seq res_ty
955
956 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
957 = do { res_ty <- expTypeToType res_ty
958 ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
959 ; expr1' <- tcPolyExpr expr1 elt_ty
960 ; expr2' <- tcPolyExpr expr2 elt_ty
961 ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
962 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
963 (idName enumFromToP) elt_ty
964 ; return $
965 mkHsWrapCo coi $ PArrSeq enum_from_to (FromTo expr1' expr2') }
966
967 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
968 = do { res_ty <- expTypeToType res_ty
969 ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
970 ; expr1' <- tcPolyExpr expr1 elt_ty
971 ; expr2' <- tcPolyExpr expr2 elt_ty
972 ; expr3' <- tcPolyExpr expr3 elt_ty
973 ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
974 ; eft <- newMethodFromName (PArrSeqOrigin seq)
975 (idName enumFromThenToP) elt_ty -- !!!FIXME: chak
976 ; return $
977 mkHsWrapCo coi $
978 PArrSeq eft (FromThenTo expr1' expr2' expr3') }
979
980 tcExpr (PArrSeq _ _) _
981 = panic "TcExpr.tcExpr: Infinite parallel array!"
982 -- the parser shouldn't have generated it and the renamer shouldn't have
983 -- let it through
984
985 {-
986 ************************************************************************
987 * *
988 Template Haskell
989 * *
990 ************************************************************************
991 -}
992
993 -- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.
994 -- Here we get rid of it and add the finalizers to the global environment.
995 --
996 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
997 tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr)))
998 res_ty
999 = do addModFinalizersWithLclEnv mod_finalizers
1000 tcExpr expr res_ty
1001 tcExpr (HsSpliceE splice) res_ty
1002 = tcSpliceExpr splice res_ty
1003 tcExpr (HsBracket brack) res_ty
1004 = tcTypedBracket brack res_ty
1005 tcExpr (HsRnBracketOut brack ps) res_ty
1006 = tcUntypedBracket brack ps res_ty
1007
1008 {-
1009 ************************************************************************
1010 * *
1011 Catch-all
1012 * *
1013 ************************************************************************
1014 -}
1015
1016 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
1017 -- Include ArrForm, ArrApp, which shouldn't appear at all
1018 -- Also HsTcBracketOut, HsQuasiQuoteE
1019
1020 {-
1021 ************************************************************************
1022 * *
1023 Arithmetic sequences [a..b] etc
1024 * *
1025 ************************************************************************
1026 -}
1027
1028 tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> ExpRhoType
1029 -> TcM (HsExpr TcId)
1030
1031 tcArithSeq witness seq@(From expr) res_ty
1032 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
1033 ; expr' <- tcPolyExpr expr elt_ty
1034 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
1035 enumFromName elt_ty
1036 ; return $ mkHsWrap wrap $
1037 ArithSeq enum_from wit' (From expr') }
1038
1039 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
1040 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
1041 ; expr1' <- tcPolyExpr expr1 elt_ty
1042 ; expr2' <- tcPolyExpr expr2 elt_ty
1043 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
1044 enumFromThenName elt_ty
1045 ; return $ mkHsWrap wrap $
1046 ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
1047
1048 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
1049 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
1050 ; expr1' <- tcPolyExpr expr1 elt_ty
1051 ; expr2' <- tcPolyExpr expr2 elt_ty
1052 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
1053 enumFromToName elt_ty
1054 ; return $ mkHsWrap wrap $
1055 ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
1056
1057 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
1058 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
1059 ; expr1' <- tcPolyExpr expr1 elt_ty
1060 ; expr2' <- tcPolyExpr expr2 elt_ty
1061 ; expr3' <- tcPolyExpr expr3 elt_ty
1062 ; eft <- newMethodFromName (ArithSeqOrigin seq)
1063 enumFromThenToName elt_ty
1064 ; return $ mkHsWrap wrap $
1065 ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
1066
1067 -----------------
1068 arithSeqEltType :: Maybe (SyntaxExpr Name) -> ExpRhoType
1069 -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id))
1070 arithSeqEltType Nothing res_ty
1071 = do { res_ty <- expTypeToType res_ty
1072 ; (coi, elt_ty) <- matchExpectedListTy res_ty
1073 ; return (mkWpCastN coi, elt_ty, Nothing) }
1074 arithSeqEltType (Just fl) res_ty
1075 = do { (elt_ty, fl')
1076 <- tcSyntaxOp ListOrigin fl [SynList] res_ty $
1077 \ [elt_ty] -> return elt_ty
1078 ; return (idHsWrapper, elt_ty, Just fl') }
1079
1080 {-
1081 ************************************************************************
1082 * *
1083 Applications
1084 * *
1085 ************************************************************************
1086 -}
1087
1088 type LHsExprArgIn = Either (LHsExpr Name) (LHsWcType Name)
1089 type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name)
1090 -- Left e => argument expression
1091 -- Right ty => visible type application
1092
1093 tcApp1 :: HsExpr Name -- either HsApp or HsAppType
1094 -> ExpRhoType -> TcM (HsExpr TcId)
1095 tcApp1 e res_ty
1096 = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
1097 ; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) }
1098 where
1099 mk_hs_app f (Left a) = mkHsApp f a
1100 mk_hs_app f (Right a) = mkHsAppTypeOut f a
1101
1102 tcApp :: Maybe SDoc -- like "The function `f' is applied to"
1103 -- or leave out to get exactly that message
1104 -> LHsExpr Name -> [LHsExprArgIn] -- Function and args
1105 -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
1106 -- (wrap, fun, args). For an ordinary function application,
1107 -- these should be assembled as (wrap (fun args)).
1108 -- But OpApp is slightly different, so that's why the caller
1109 -- must assemble
1110
1111 tcApp m_herald orig_fun orig_args res_ty
1112 = go orig_fun orig_args
1113 where
1114 go :: LHsExpr Name -> [LHsExprArgIn]
1115 -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
1116 go (L _ (HsPar e)) args = go e args
1117 go (L _ (HsApp e1 e2)) args = go e1 (Left e2:args)
1118 go (L _ (HsAppType e t)) args = go e (Right t:args)
1119
1120 go (L loc (HsVar (L _ fun))) args
1121 | fun `hasKey` tagToEnumKey
1122 , count isLeft args == 1
1123 = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
1124 ; return (wrap, expr, args) }
1125
1126 | fun `hasKey` seqIdKey
1127 , count isLeft args == 2
1128 = do { (wrap, expr, args) <- tcSeq loc fun args res_ty
1129 ; return (wrap, expr, args) }
1130
1131 go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)
1132 | Just sig_ty <- obviousSig arg
1133 = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
1134 ; sel_name <- disambiguateSelector lbl sig_tc_ty
1135 ; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args }
1136
1137 go fun args
1138 = do { -- Type-check the function
1139 ; (fun1, fun_sigma) <- tcInferFun fun
1140 ; let orig = exprCtOrigin (unLoc fun)
1141
1142 ; (wrap_fun, args1, actual_res_ty)
1143 <- tcArgs fun fun_sigma orig args
1144 (m_herald `orElse` mk_app_msg fun)
1145
1146 -- this is just like tcWrapResult, but the types don't line
1147 -- up to call that function
1148 ; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
1149 tcSubTypeDS_NC_O orig GenSigCtxt
1150 (Just $ foldl mk_hs_app fun args)
1151 actual_res_ty res_ty
1152
1153 ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
1154
1155 mk_hs_app f (Left a) = mkHsApp f a
1156 mk_hs_app f (Right a) = mkHsAppType f a
1157
1158 mk_app_msg :: LHsExpr Name -> SDoc
1159 mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun)
1160 , text "is applied to"]
1161
1162 mk_op_msg :: LHsExpr Name -> SDoc
1163 mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
1164
1165 ----------------
1166 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)
1167 -- Infer type of a function
1168 tcInferFun (L loc (HsVar (L _ name)))
1169 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
1170 -- Don't wrap a context around a plain Id
1171 ; return (L loc fun, ty) }
1172
1173 tcInferFun (L loc (HsRecFld f))
1174 = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
1175 -- Don't wrap a context around a plain Id
1176 ; return (L loc fun, ty) }
1177
1178 tcInferFun fun
1179 = tcInferSigma fun
1180 -- NB: tcInferSigma; see TcUnify
1181 -- Note [Deep instantiation of InferResult]
1182
1183
1184 ----------------
1185 -- | Type-check the arguments to a function, possibly including visible type
1186 -- applications
1187 tcArgs :: LHsExpr Name -- ^ The function itself (for err msgs only)
1188 -> TcSigmaType -- ^ the (uninstantiated) type of the function
1189 -> CtOrigin -- ^ the origin for the function's type
1190 -> [LHsExprArgIn] -- ^ the args
1191 -> SDoc -- ^ the herald for matchActualFunTys
1192 -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
1193 -- ^ (a wrapper for the function, the tc'd args, result type)
1194 tcArgs fun orig_fun_ty fun_orig orig_args herald
1195 = go [] 1 orig_fun_ty orig_args
1196 where
1197 orig_arity = length orig_args
1198
1199 go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
1200
1201 go acc_args n fun_ty (Right hs_ty_arg:args)
1202 = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
1203 -- wrap1 :: fun_ty "->" upsilon_ty
1204 ; case tcSplitForAllTy_maybe upsilon_ty of
1205 Just (tvb, inner_ty) ->
1206 do { let tv = binderVar tvb
1207 vis = binderArgFlag tvb
1208 kind = tyVarKind tv
1209 ; MASSERT2( vis == Specified
1210 , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr tvb
1211 , ppr inner_ty, pprTyVar tv
1212 , ppr vis ]) )
1213 ; ty_arg <- tcHsTypeApp hs_ty_arg kind
1214 ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty
1215 ; (inner_wrap, args', res_ty)
1216 <- go acc_args (n+1) insted_ty args
1217 -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
1218 ; let inst_wrap = mkWpTyApps [ty_arg]
1219 ; return ( inner_wrap <.> inst_wrap <.> wrap1
1220 , Right hs_ty_arg : args'
1221 , res_ty ) }
1222 _ -> ty_app_err upsilon_ty hs_ty_arg }
1223
1224 go acc_args n fun_ty (Left arg : args)
1225 = do { (wrap, [arg_ty], res_ty)
1226 <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
1227 acc_args orig_arity
1228 -- wrap :: fun_ty "->" arg_ty -> res_ty
1229 ; arg' <- tcArg fun arg arg_ty n
1230 ; (inner_wrap, args', inner_res_ty)
1231 <- go (arg_ty : acc_args) (n+1) res_ty args
1232 -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
1233 ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap
1234 , Left arg' : args'
1235 , inner_res_ty ) }
1236
1237 ty_app_err ty arg
1238 = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty
1239 ; failWith $
1240 text "Cannot apply expression of type" <+> quotes (ppr ty) $$
1241 text "to a visible type argument" <+> quotes (ppr arg) }
1242
1243 ----------------
1244 tcArg :: LHsExpr Name -- The function (for error messages)
1245 -> LHsExpr Name -- Actual arguments
1246 -> TcRhoType -- expected arg type
1247 -> Int -- # of argument
1248 -> TcM (LHsExpr TcId) -- Resulting argument
1249 tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $
1250 tcPolyExprNC arg ty
1251
1252 ----------------
1253 tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
1254 tcTupArgs args tys
1255 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
1256 where
1257 go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
1258 go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
1259 ; return (L l (Present expr')) }
1260
1261 ---------------------------
1262 -- See TcType.SyntaxOpType also for commentary
1263 tcSyntaxOp :: CtOrigin
1264 -> SyntaxExpr Name
1265 -> [SyntaxOpType] -- ^ shape of syntax operator arguments
1266 -> ExpRhoType -- ^ overall result type
1267 -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
1268 -> TcM (a, SyntaxExpr TcId)
1269 -- ^ Typecheck a syntax operator
1270 -- The operator is always a variable at this stage (i.e. renamer output)
1271 tcSyntaxOp orig expr arg_tys res_ty
1272 = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
1273
1274 -- | Slightly more general version of 'tcSyntaxOp' that allows the caller
1275 -- to specify the shape of the result of the syntax operator
1276 tcSyntaxOpGen :: CtOrigin
1277 -> SyntaxExpr Name
1278 -> [SyntaxOpType]
1279 -> SyntaxOpType
1280 -> ([TcSigmaType] -> TcM a)
1281 -> TcM (a, SyntaxExpr TcId)
1282 tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })
1283 arg_tys res_ty thing_inside
1284 = do { (expr, sigma) <- tcInferId op
1285 ; (result, expr_wrap, arg_wraps, res_wrap)
1286 <- tcSynArgA orig sigma arg_tys res_ty $
1287 thing_inside
1288 ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap expr
1289 , syn_arg_wraps = arg_wraps
1290 , syn_res_wrap = res_wrap }) }
1291
1292 tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other)
1293
1294 {-
1295 Note [tcSynArg]
1296 ~~~~~~~~~~~~~~~
1297 Because of the rich structure of SyntaxOpType, we must do the
1298 contra-/covariant thing when working down arrows, to get the
1299 instantiation vs. skolemisation decisions correct (and, more
1300 obviously, the orientation of the HsWrappers). We thus have
1301 two tcSynArgs.
1302 -}
1303
1304 -- works on "expected" types, skolemising where necessary
1305 -- See Note [tcSynArg]
1306 tcSynArgE :: CtOrigin
1307 -> TcSigmaType
1308 -> SyntaxOpType -- ^ shape it is expected to have
1309 -> ([TcSigmaType] -> TcM a) -- ^ check the arguments
1310 -> TcM (a, HsWrapper)
1311 -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
1312 tcSynArgE orig sigma_ty syn_ty thing_inside
1313 = do { (skol_wrap, (result, ty_wrapper))
1314 <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty ->
1315 go rho_ty syn_ty
1316 ; return (result, skol_wrap <.> ty_wrapper) }
1317 where
1318 go rho_ty SynAny
1319 = do { result <- thing_inside [rho_ty]
1320 ; return (result, idHsWrapper) }
1321
1322 go rho_ty SynRho -- same as SynAny, because we skolemise eagerly
1323 = do { result <- thing_inside [rho_ty]
1324 ; return (result, idHsWrapper) }
1325
1326 go rho_ty SynList
1327 = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
1328 ; result <- thing_inside [elt_ty]
1329 ; return (result, mkWpCastN list_co) }
1330
1331 go rho_ty (SynFun arg_shape res_shape)
1332 = do { ( ( ( (result, arg_ty, res_ty)
1333 , res_wrapper ) -- :: res_ty_out "->" res_ty
1334 , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out
1335 , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty
1336 <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $
1337 \ [arg_ty] res_ty ->
1338 do { arg_tc_ty <- expTypeToType arg_ty
1339 ; res_tc_ty <- expTypeToType res_ty
1340
1341 -- another nested arrow is too much for now,
1342 -- but I bet we'll never need this
1343 ; MASSERT2( case arg_shape of
1344 SynFun {} -> False;
1345 _ -> True
1346 , text "Too many nested arrows in SyntaxOpType" $$
1347 pprCtOrigin orig )
1348
1349 ; tcSynArgA orig arg_tc_ty [] arg_shape $
1350 \ arg_results ->
1351 tcSynArgE orig res_tc_ty res_shape $
1352 \ res_results ->
1353 do { result <- thing_inside (arg_results ++ res_results)
1354 ; return (result, arg_tc_ty, res_tc_ty) }}
1355
1356 ; return ( result
1357 , match_wrapper <.>
1358 mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
1359 arg_ty res_ty ) }
1360 where
1361 herald = text "This rebindable syntax expects a function with"
1362
1363 go rho_ty (SynType the_ty)
1364 = do { wrap <- tcSubTypeET orig GenSigCtxt the_ty rho_ty
1365 ; result <- thing_inside []
1366 ; return (result, wrap) }
1367
1368 -- works on "actual" types, instantiating where necessary
1369 -- See Note [tcSynArg]
1370 tcSynArgA :: CtOrigin
1371 -> TcSigmaType
1372 -> [SyntaxOpType] -- ^ argument shapes
1373 -> SyntaxOpType -- ^ result shape
1374 -> ([TcSigmaType] -> TcM a) -- ^ check the arguments
1375 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
1376 -- ^ returns a wrapper to be applied to the original function,
1377 -- wrappers to be applied to arguments
1378 -- and a wrapper to be applied to the overall expression
1379 tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
1380 = do { (match_wrapper, arg_tys, res_ty)
1381 <- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty
1382 -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
1383 ; ((result, res_wrapper), arg_wrappers)
1384 <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
1385 tc_syn_arg res_ty res_shape $ \ res_results ->
1386 thing_inside (arg_results ++ res_results)
1387 ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
1388 where
1389 herald = text "This rebindable syntax expects a function with"
1390
1391 tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
1392 -> ([TcSigmaType] -> TcM a)
1393 -> TcM (a, [HsWrapper])
1394 -- the wrappers are for arguments
1395 tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
1396 = do { ((result, arg_wraps), arg_wrap)
1397 <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results ->
1398 tc_syn_args_e arg_tys arg_shapes $ \ args_results ->
1399 thing_inside (arg1_results ++ args_results)
1400 ; return (result, arg_wrap : arg_wraps) }
1401 tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []
1402
1403 tc_syn_arg :: TcSigmaType -> SyntaxOpType
1404 -> ([TcSigmaType] -> TcM a)
1405 -> TcM (a, HsWrapper)
1406 -- the wrapper applies to the overall result
1407 tc_syn_arg res_ty SynAny thing_inside
1408 = do { result <- thing_inside [res_ty]
1409 ; return (result, idHsWrapper) }
1410 tc_syn_arg res_ty SynRho thing_inside
1411 = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty
1412 -- inst_wrap :: res_ty "->" rho_ty
1413 ; result <- thing_inside [rho_ty]
1414 ; return (result, inst_wrap) }
1415 tc_syn_arg res_ty SynList thing_inside
1416 = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
1417 -- inst_wrap :: res_ty "->" rho_ty
1418 ; (list_co, elt_ty) <- matchExpectedListTy rho_ty
1419 -- list_co :: [elt_ty] ~N rho_ty
1420 ; result <- thing_inside [elt_ty]
1421 ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
1422 tc_syn_arg _ (SynFun {}) _
1423 = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
1424 tc_syn_arg res_ty (SynType the_ty) thing_inside
1425 = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty
1426 ; result <- thing_inside []
1427 ; return (result, wrap) }
1428
1429 {-
1430 Note [Push result type in]
1431 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1432 Unify with expected result before type-checking the args so that the
1433 info from res_ty percolates to args. This is when we might detect a
1434 too-few args situation. (One can think of cases when the opposite
1435 order would give a better error message.)
1436 experimenting with putting this first.
1437
1438 Here's an example where it actually makes a real difference
1439
1440 class C t a b | t a -> b
1441 instance C Char a Bool
1442
1443 data P t a = forall b. (C t a b) => MkP b
1444 data Q t = MkQ (forall a. P t a)
1445
1446 f1, f2 :: Q Char;
1447 f1 = MkQ (MkP True)
1448 f2 = MkQ (MkP True :: forall a. P Char a)
1449
1450 With the change, f1 will type-check, because the 'Char' info from
1451 the signature is propagated into MkQ's argument. With the check
1452 in the other order, the extra signature in f2 is reqd.
1453
1454 ************************************************************************
1455 * *
1456 Expressions with a type signature
1457 expr :: type
1458 * *
1459 ********************************************************************* -}
1460
1461 tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType)
1462 tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
1463 = setSrcSpan loc $ -- Sets the location for the implication constraint
1464 do { (tv_prs, theta, tau) <- tcInstType (tcInstSigTyVars loc) poly_id
1465 ; given <- newEvVars theta
1466 ; let skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
1467 skol_tvs = map snd tv_prs
1468 ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $
1469 tcExtendTyVarEnv2 tv_prs $
1470 tcPolyExprNC expr tau
1471
1472 ; let poly_wrap = mkWpTyLams skol_tvs
1473 <.> mkWpLams given
1474 <.> mkWpLet ev_binds
1475 ; return (mkLHsWrap poly_wrap expr', idType poly_id) }
1476
1477 tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
1478 = setSrcSpan loc $ -- Sets the location for the implication constraint
1479 do { (tclvl, wanted, (expr', sig_inst))
1480 <- pushLevelAndCaptureConstraints $
1481 do { sig_inst <- tcInstSig sig
1482 ; expr' <- tcExtendTyVarEnv2 (sig_inst_skols sig_inst) $
1483 tcExtendTyVarEnv2 (sig_inst_wcs sig_inst) $
1484 tcPolyExprNC expr (sig_inst_tau sig_inst)
1485 ; return (expr', sig_inst) }
1486 -- See Note [Partial expression signatures]
1487 ; let tau = sig_inst_tau sig_inst
1488 infer_mode | null (sig_inst_theta sig_inst)
1489 , isNothing (sig_inst_wcx sig_inst)
1490 = ApplyMR
1491 | otherwise
1492 = NoRestrictions
1493 ; (qtvs, givens, ev_binds)
1494 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
1495 ; tau <- zonkTcType tau
1496 ; let inferred_theta = map evVarPred givens
1497 tau_tvs = tyCoVarsOfType tau
1498 ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta
1499 tau_tvs qtvs (Just sig_inst)
1500 ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau
1501 my_sigma = mkForAllTys binders (mkPhiTy my_theta tau)
1502 ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
1503 then return idHsWrapper -- Fast path; also avoids complaint when we infer
1504 -- an ambiguouse type and have AllowAmbiguousType
1505 -- e..g infer x :: forall a. F a -> Int
1506 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma
1507
1508 ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
1509 ; let poly_wrap = wrap
1510 <.> mkWpTyLams qtvs
1511 <.> mkWpLams givens
1512 <.> mkWpLet ev_binds
1513 ; return (mkLHsWrap poly_wrap expr', my_sigma) }
1514
1515
1516 {- Note [Partial expression signatures]
1517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1518 Partial type signatures on expressions are easy to get wrong. But
1519 here is a guiding principile
1520 e :: ty
1521 should behave like
1522 let x :: ty
1523 x = e
1524 in x
1525
1526 So for partial signatures we apply the MR if no context is given. So
1527 e :: IO _ apply the MR
1528 e :: _ => IO _ do not apply the MR
1529 just like in TcBinds.decideGeneralisationPlan
1530
1531 This makes a difference (Trac #11670):
1532 peek :: Ptr a -> IO CLong
1533 peek ptr = peekElemOff undefined 0 :: _
1534 from (peekElemOff undefined 0) we get
1535 type: IO w
1536 constraints: Storable w
1537
1538 We must NOT try to generalise over 'w' because the signature specifies
1539 no constraints so we'll complain about not being able to solve
1540 Storable w. Instead, don't generalise; then _ gets instantiated to
1541 CLong, as it should.
1542 -}
1543
1544 {- *********************************************************************
1545 * *
1546 tcInferId
1547 * *
1548 ********************************************************************* -}
1549
1550 tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)
1551 tcCheckId name res_ty
1552 = do { (expr, actual_res_ty) <- tcInferId name
1553 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
1554 ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
1555 tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty }
1556
1557 tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId)
1558 tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty
1559 = do { (expr, actual_res_ty) <- tcInferRecSelId f
1560 ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
1561 tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty }
1562 tcCheckRecSelId (Ambiguous lbl _) res_ty
1563 = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
1564 Nothing -> ambiguousSelector lbl
1565 Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
1566 ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
1567
1568 ------------------------
1569 tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
1570 tcInferRecSelId (Unambiguous (L _ lbl) sel)
1571 = do { (expr', ty) <- tc_infer_id lbl sel
1572 ; return (expr', ty) }
1573 tcInferRecSelId (Ambiguous lbl _)
1574 = ambiguousSelector lbl
1575
1576 ------------------------
1577 tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType)
1578 -- Look up an occurrence of an Id
1579 -- Do not instantiate its type
1580 tcInferId id_name
1581 | id_name `hasKey` tagToEnumKey
1582 = failWithTc (text "tagToEnum# must appear applied to one argument")
1583 -- tcApp catches the case (tagToEnum# arg)
1584
1585 | id_name `hasKey` assertIdKey
1586 = do { dflags <- getDynFlags
1587 ; if gopt Opt_IgnoreAsserts dflags
1588 then tc_infer_id (nameRdrName id_name) id_name
1589 else tc_infer_assert id_name }
1590
1591 | otherwise
1592 = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name
1593 ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
1594 ; return (expr, ty) }
1595
1596 tc_infer_assert :: Name -> TcM (HsExpr TcId, TcSigmaType)
1597 -- Deal with an occurrence of 'assert'
1598 -- See Note [Adding the implicit parameter to 'assert']
1599 tc_infer_assert assert_name
1600 = do { assert_error_id <- tcLookupId assertErrorName
1601 ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
1602 (idType assert_error_id)
1603 ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho)
1604 }
1605
1606 tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType)
1607 tc_infer_id lbl id_name
1608 = do { thing <- tcLookup id_name
1609 ; case thing of
1610 ATcId { tct_id = id }
1611 -> do { check_naughty id -- Note [Local record selectors]
1612 ; checkThLocalId id
1613 ; return_id id }
1614
1615 AGlobal (AnId id)
1616 -> do { check_naughty id
1617 ; return_id id }
1618 -- A global cannot possibly be ill-staged
1619 -- nor does it need the 'lifting' treatment
1620 -- hence no checkTh stuff here
1621
1622 AGlobal (AConLike cl) -> case cl of
1623 RealDataCon con -> return_data_con con
1624 PatSynCon ps -> tcPatSynBuilderOcc ps
1625
1626 _ -> failWithTc $
1627 ppr thing <+> text "used where a value identifier was expected" }
1628 where
1629 return_id id = return (HsVar (noLoc id), idType id)
1630
1631 return_data_con con
1632 -- For data constructors, must perform the stupid-theta check
1633 | null stupid_theta
1634 = return_id con_wrapper_id
1635
1636 | otherwise
1637 -- See Note [Instantiating stupid theta]
1638 = do { let (tvs, theta, rho) = tcSplitSigmaTy (idType con_wrapper_id)
1639 ; (subst, tvs') <- newMetaTyVars tvs
1640 ; let tys' = mkTyVarTys tvs'
1641 theta' = substTheta subst theta
1642 rho' = substTy subst rho
1643 ; wrap <- instCall (OccurrenceOf id_name) tys' theta'
1644 ; addDataConStupidTheta con tys'
1645 ; return (mkHsWrap wrap (HsVar (noLoc con_wrapper_id)), rho') }
1646
1647 where
1648 con_wrapper_id = dataConWrapId con
1649 stupid_theta = dataConStupidTheta con
1650
1651 check_naughty id
1652 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
1653 | otherwise = return ()
1654
1655
1656 tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr TcId)
1657 -- Typecheck an occurrence of an unbound Id
1658 --
1659 -- Some of these started life as a true expression hole "_".
1660 -- Others might simply be variables that accidentally have no binding site
1661 --
1662 -- We turn all of them into HsVar, since HsUnboundVar can't contain an
1663 -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
1664 -- not unbound any more!
1665 tcUnboundId unbound res_ty
1666 = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (Trac #12531)
1667 ; let occ = unboundVarOcc unbound
1668 ; name <- newSysName occ
1669 ; let ev = mkLocalId name ty
1670 ; loc <- getCtLocM HoleOrigin Nothing
1671 ; let can = CHoleCan { cc_ev = CtWanted { ctev_pred = ty
1672 , ctev_dest = EvVarDest ev
1673 , ctev_nosh = WDeriv
1674 , ctev_loc = loc}
1675 , cc_hole = ExprHole unbound }
1676 ; emitInsoluble can
1677 ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty }
1678
1679
1680 {-
1681 Note [Adding the implicit parameter to 'assert']
1682 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1683 The typechecker transforms (assert e1 e2) to (assertError e1 e2).
1684 This isn't really the Right Thing because there's no way to "undo"
1685 if you want to see the original source code in the typechecker
1686 output. We'll have fix this in due course, when we care more about
1687 being able to reconstruct the exact original program.
1688
1689 Note [tagToEnum#]
1690 ~~~~~~~~~~~~~~~~~
1691 Nasty check to ensure that tagToEnum# is applied to a type that is an
1692 enumeration TyCon. Unification may refine the type later, but this
1693 check won't see that, alas. It's crude, because it relies on our
1694 knowing *now* that the type is ok, which in turn relies on the
1695 eager-unification part of the type checker pushing enough information
1696 here. In theory the Right Thing to do is to have a new form of
1697 constraint but I definitely cannot face that! And it works ok as-is.
1698
1699 Here's are two cases that should fail
1700 f :: forall a. a
1701 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1702
1703 g :: Int
1704 g = tagToEnum# 0 -- Int is not an enumeration
1705
1706 When data type families are involved it's a bit more complicated.
1707 data family F a
1708 data instance F [Int] = A | B | C
1709 Then we want to generate something like
1710 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1711 Usually that coercion is hidden inside the wrappers for
1712 constructors of F [Int] but here we have to do it explicitly.
1713
1714 It's all grotesquely complicated.
1715
1716 Note [Instantiating stupid theta]
1717 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1718 Normally, when we infer the type of an Id, we don't instantiate,
1719 because we wish to allow for visible type application later on.
1720 But if a datacon has a stupid theta, we're a bit stuck. We need
1721 to emit the stupid theta constraints with instantiated types. It's
1722 difficult to defer this to the lazy instantiation, because a stupid
1723 theta has no spot to put it in a type. So we just instantiate eagerly
1724 in this case. Thus, users cannot use visible type application with
1725 a data constructor sporting a stupid theta. I won't feel so bad for
1726 the users that complain.
1727
1728 -}
1729
1730 tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]
1731 -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
1732 -- (seq e1 e2) :: res_ty
1733 -- We need a special typing rule because res_ty can be unboxed
1734 -- See Note [Typing rule for seq]
1735 tcSeq loc fun_name args res_ty
1736 = do { fun <- tcLookupId fun_name
1737 ; (arg1_ty, args1) <- case args of
1738 (Right hs_ty_arg1 : args1)
1739 -> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind
1740 ; return (ty_arg1, args1) }
1741
1742 _ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind
1743 ; return (arg_ty1, args) }
1744
1745 ; (arg1, arg2, arg2_exp_ty) <- case args1 of
1746 [Right hs_ty_arg2, Left term_arg1, Left term_arg2]
1747 -> do { arg2_kind <- newOpenTypeKind
1748 ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 arg2_kind
1749 -- see Note [Typing rule for seq]
1750 ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg2 res_ty
1751 ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
1752 [Left term_arg1, Left term_arg2]
1753 -> return (term_arg1, term_arg2, res_ty)
1754 _ -> too_many_args "seq" args
1755
1756 ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
1757 ; arg2' <- tcMonoExpr arg2 arg2_exp_ty
1758 ; res_ty <- readExpType res_ty -- by now, it's surely filled in
1759 ; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun)))
1760 ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
1761 ; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
1762
1763 tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
1764 -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
1765 -- tagToEnum# :: forall a. Int# -> a
1766 -- See Note [tagToEnum#] Urgh!
1767 tcTagToEnum loc fun_name args res_ty
1768 = do { fun <- tcLookupId fun_name
1769
1770 ; arg <- case args of
1771 [Right hs_ty_arg, Left term_arg]
1772 -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
1773 ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty
1774 -- other than influencing res_ty, we just
1775 -- don't care about a type arg passed in.
1776 -- So drop the evidence.
1777 ; return term_arg }
1778 [Left term_arg] -> do { _ <- expTypeToType res_ty
1779 ; return term_arg }
1780 _ -> too_many_args "tagToEnum#" args
1781
1782 ; res_ty <- readExpType res_ty
1783 ; ty' <- zonkTcType res_ty
1784
1785 -- Check that the type is algebraic
1786 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1787 Just (tc, tc_args) = mb_tc_app
1788 ; checkTc (isJust mb_tc_app)
1789 (mk_error ty' doc1)
1790
1791 -- Look through any type family
1792 ; fam_envs <- tcGetFamInstEnvs
1793 ; let (rep_tc, rep_args, coi)
1794 = tcLookupDataFamInst fam_envs tc tc_args
1795 -- coi :: tc tc_args ~R rep_tc rep_args
1796
1797 ; checkTc (isEnumerationTyCon rep_tc)
1798 (mk_error ty' doc2)
1799
1800 ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
1801 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
1802 rep_ty = mkTyConApp rep_tc rep_args
1803
1804 ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
1805 -- coi is a Representational coercion
1806 where
1807 doc1 = vcat [ text "Specify the type by giving a type signature"
1808 , text "e.g. (tagToEnum# x) :: Bool" ]
1809 doc2 = text "Result type must be an enumeration type"
1810
1811 mk_error :: TcType -> SDoc -> SDoc
1812 mk_error ty what
1813 = hang (text "Bad call to tagToEnum#"
1814 <+> text "at type" <+> ppr ty)
1815 2 what
1816
1817 too_many_args :: String -> [LHsExprArgIn] -> TcM a
1818 too_many_args fun args
1819 = failWith $
1820 hang (text "Too many type arguments to" <+> text fun <> colon)
1821 2 (sep (map pp args))
1822 where
1823 pp (Left e) = pprParendLExpr e
1824 pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
1825
1826
1827 {-
1828 ************************************************************************
1829 * *
1830 Template Haskell checks
1831 * *
1832 ************************************************************************
1833 -}
1834
1835 checkThLocalId :: Id -> TcM ()
1836 checkThLocalId id
1837 = do { mb_local_use <- getStageAndBindLevel (idName id)
1838 ; case mb_local_use of
1839 Just (top_lvl, bind_lvl, use_stage)
1840 | thLevel use_stage > bind_lvl
1841 , isNotTopLevel top_lvl
1842 -> checkCrossStageLifting id use_stage
1843 _ -> return () -- Not a locally-bound thing, or
1844 -- no cross-stage link
1845 }
1846
1847 --------------------------------------
1848 checkCrossStageLifting :: Id -> ThStage -> TcM ()
1849 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
1850 -- we must check whether there's a cross-stage lift to do
1851 -- Examples \x -> [|| x ||]
1852 -- [|| map ||]
1853 -- There is no error-checking to do, because the renamer did that
1854 --
1855 -- This is similar to checkCrossStageLifting in RnSplice, but
1856 -- this code is applied to *typed* brackets.
1857
1858 checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
1859 = -- Nested identifiers, such as 'x' in
1860 -- E.g. \x -> [|| h x ||]
1861 -- We must behave as if the reference to x was
1862 -- h $(lift x)
1863 -- We use 'x' itself as the splice proxy, used by
1864 -- the desugarer to stitch it all back together.
1865 -- If 'x' occurs many times we may get many identical
1866 -- bindings of the same splice proxy, but that doesn't
1867 -- matter, although it's a mite untidy.
1868 do { let id_ty = idType id
1869 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1870 -- If x is polymorphic, its occurrence sites might
1871 -- have different instantiations, so we can't use plain
1872 -- 'x' as the splice proxy name. I don't know how to
1873 -- solve this, and it's probably unimportant, so I'm
1874 -- just going to flag an error for now
1875
1876 ; lift <- if isStringTy id_ty then
1877 do { sid <- tcLookupId THNames.liftStringName
1878 -- See Note [Lifting strings]
1879 ; return (HsVar (noLoc sid)) }
1880 else
1881 setConstraintVar lie_var $
1882 -- Put the 'lift' constraint into the right LIE
1883 newMethodFromName (OccurrenceOf (idName id))
1884 THNames.liftName id_ty
1885
1886 -- Update the pending splices
1887 ; ps <- readMutVar ps_var
1888 ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
1889 ; writeMutVar ps_var (pending_splice : ps)
1890
1891 ; return () }
1892
1893 checkCrossStageLifting _ _ = return ()
1894
1895 polySpliceErr :: Id -> SDoc
1896 polySpliceErr id
1897 = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)
1898
1899 {-
1900 Note [Lifting strings]
1901 ~~~~~~~~~~~~~~~~~~~~~~
1902 If we see $(... [| s |] ...) where s::String, we don't want to
1903 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1904 So this conditional short-circuits the lifting mechanism to generate
1905 (liftString "xy") in that case. I didn't want to use overlapping instances
1906 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1907 errors in a polymorphic situation.
1908
1909 If this check fails (which isn't impossible) we get another chance; see
1910 Note [Converting strings] in Convert.hs
1911
1912 Local record selectors
1913 ~~~~~~~~~~~~~~~~~~~~~~
1914 Record selectors for TyCons in this module are ordinary local bindings,
1915 which show up as ATcIds rather than AGlobals. So we need to check for
1916 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1917
1918
1919 ************************************************************************
1920 * *
1921 \subsection{Record bindings}
1922 * *
1923 ************************************************************************
1924 -}
1925
1926 getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
1927 -- These tyvars must not change across the updates
1928 getFixedTyVars upd_fld_occs univ_tvs cons
1929 = mkVarSet [tv1 | con <- cons
1930 , let (u_tvs, _, eqspec, prov_theta
1931 , req_theta, arg_tys, _)
1932 = conLikeFullSig con
1933 theta = eqSpecPreds eqspec
1934 ++ prov_theta
1935 ++ req_theta
1936 flds = conLikeFieldLabels con
1937 fixed_tvs = exactTyCoVarsOfTypes fixed_tys
1938 -- fixed_tys: See Note [Type of a record update]
1939 `unionVarSet` tyCoVarsOfTypes theta
1940 -- Universally-quantified tyvars that
1941 -- appear in any of the *implicit*
1942 -- arguments to the constructor are fixed
1943 -- See Note [Implicit type sharing]
1944
1945 fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
1946 , not (flLabel fl `elem` upd_fld_occs)]
1947 , (tv1,tv) <- univ_tvs `zip` u_tvs
1948 , tv `elemVarSet` fixed_tvs ]
1949
1950 {-
1951 Note [Disambiguating record fields]
1952 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1953 When the -XDuplicateRecordFields extension is used, and the renamer
1954 encounters a record selector or update that it cannot immediately
1955 disambiguate (because it involves fields that belong to multiple
1956 datatypes), it will defer resolution of the ambiguity to the
1957 typechecker. In this case, the `Ambiguous` constructor of
1958 `AmbiguousFieldOcc` is used.
1959
1960 Consider the following definitions:
1961
1962 data S = MkS { foo :: Int }
1963 data T = MkT { foo :: Int, bar :: Int }
1964 data U = MkU { bar :: Int, baz :: Int }
1965
1966 When the renamer sees `foo` as a selector or an update, it will not
1967 know which parent datatype is in use.
1968
1969 For selectors, there are two possible ways to disambiguate:
1970
1971 1. Check if the pushed-in type is a function whose domain is a
1972 datatype, for example:
1973
1974 f s = (foo :: S -> Int) s
1975
1976 g :: T -> Int
1977 g = foo
1978
1979 This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
1980
1981 2. Check if the selector is applied to an argument that has a type
1982 signature, for example:
1983
1984 h = foo (s :: S)
1985
1986 This is checked by `tcApp`.
1987
1988
1989 Updates are slightly more complex. The `disambiguateRecordBinds`
1990 function tries to determine the parent datatype in three ways:
1991
1992 1. Check for types that have all the fields being updated. For example:
1993
1994 f x = x { foo = 3, bar = 2 }
1995
1996 Here `f` must be updating `T` because neither `S` nor `U` have
1997 both fields. This may also discover that no possible type exists.
1998 For example the following will be rejected:
1999
2000 f' x = x { foo = 3, baz = 3 }
2001
2002 2. Use the type being pushed in, if it is already a TyConApp. The
2003 following are valid updates to `T`:
2004
2005 g :: T -> T
2006 g x = x { foo = 3 }
2007
2008 g' x = x { foo = 3 } :: T
2009
2010 3. Use the type signature of the record expression, if it exists and
2011 is a TyConApp. Thus this is valid update to `T`:
2012
2013 h x = (x :: T) { foo = 3 }
2014
2015
2016 Note that we do not look up the types of variables being updated, and
2017 no constraint-solving is performed, so for example the following will
2018 be rejected as ambiguous:
2019
2020 let bad (s :: S) = foo s
2021
2022 let r :: T
2023 r = blah
2024 in r { foo = 3 }
2025
2026 \r. (r { foo = 3 }, r :: T )
2027
2028 We could add further tests, of a more heuristic nature. For example,
2029 rather than looking for an explicit signature, we could try to infer
2030 the type of the argument to a selector or the record expression being
2031 updated, in case we are lucky enough to get a TyConApp straight
2032 away. However, it might be hard for programmers to predict whether a
2033 particular update is sufficiently obvious for the signature to be
2034 omitted. Moreover, this might change the behaviour of typechecker in
2035 non-obvious ways.
2036
2037 See also Note [HsRecField and HsRecUpdField] in HsPat.
2038 -}
2039
2040 -- Given a RdrName that refers to multiple record fields, and the type
2041 -- of its argument, try to determine the name of the selector that is
2042 -- meant.
2043 disambiguateSelector :: Located RdrName -> Type -> TcM Name
2044 disambiguateSelector lr@(L _ rdr) parent_type
2045 = do { fam_inst_envs <- tcGetFamInstEnvs
2046 ; case tyConOf fam_inst_envs parent_type of
2047 Nothing -> ambiguousSelector lr
2048 Just p ->
2049 do { xs <- lookupParents rdr
2050 ; let parent = RecSelData p
2051 ; case lookup parent xs of
2052 Just gre -> do { addUsedGRE True gre
2053 ; return (gre_name gre) }
2054 Nothing -> failWithTc (fieldNotInType parent rdr) } }
2055
2056 -- This field name really is ambiguous, so add a suitable "ambiguous
2057 -- occurrence" error, then give up.
2058 ambiguousSelector :: Located RdrName -> TcM a
2059 ambiguousSelector (L _ rdr)
2060 = do { env <- getGlobalRdrEnv
2061 ; let gres = lookupGRE_RdrName rdr env
2062 ; setErrCtxt [] $ addNameClashErrRn rdr gres
2063 ; failM }
2064
2065 -- Disambiguate the fields in a record update.
2066 -- See Note [Disambiguating record fields]
2067 disambiguateRecordBinds :: LHsExpr Name -> TcRhoType
2068 -> [LHsRecUpdField Name] -> ExpRhoType
2069 -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
2070 disambiguateRecordBinds record_expr record_rho rbnds res_ty
2071 -- Are all the fields unambiguous?
2072 = case mapM isUnambiguous rbnds of
2073 -- If so, just skip to looking up the Ids
2074 -- Always the case if DuplicateRecordFields is off
2075 Just rbnds' -> mapM lookupSelector rbnds'
2076 Nothing -> -- If not, try to identify a single parent
2077 do { fam_inst_envs <- tcGetFamInstEnvs
2078 -- Look up the possible parents for each field
2079 ; rbnds_with_parents <- getUpdFieldsParents
2080 ; let possible_parents = map (map fst . snd) rbnds_with_parents
2081 -- Identify a single parent
2082 ; p <- identifyParent fam_inst_envs possible_parents
2083 -- Pick the right selector with that parent for each field
2084 ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
2085 where
2086 -- Extract the selector name of a field update if it is unambiguous
2087 isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)
2088 isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
2089 Unambiguous _ sel_name -> Just (x, sel_name)
2090 Ambiguous{} -> Nothing
2091
2092 -- Look up the possible parents and selector GREs for each field
2093 getUpdFieldsParents :: TcM [(LHsRecUpdField Name
2094 , [(RecSelParent, GlobalRdrElt)])]
2095 getUpdFieldsParents
2096 = fmap (zip rbnds) $ mapM
2097 (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
2098 rbnds
2099
2100 -- Given a the lists of possible parents for each field,
2101 -- identify a single parent
2102 identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
2103 identifyParent fam_inst_envs possible_parents
2104 = case foldr1 intersect possible_parents of
2105 -- No parents for all fields: record update is ill-typed
2106 [] -> failWithTc (noPossibleParents rbnds)
2107
2108 -- Exactly one datatype with all the fields: use that
2109 [p] -> return p
2110
2111 -- Multiple possible parents: try harder to disambiguate
2112 -- Can we get a parent TyCon from the pushed-in type?
2113 _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)
2114
2115 -- Does the expression being updated have a type signature?
2116 -- If so, try to extract a parent TyCon from it
2117 | Just {} <- obviousSig (unLoc record_expr)
2118 , Just tc <- tyConOf fam_inst_envs record_rho
2119 -> return (RecSelData tc)
2120
2121 -- Nothing else we can try...
2122 _ -> failWithTc badOverloadedUpdate
2123
2124 -- Make a field unambiguous by choosing the given parent.
2125 -- Emits an error if the field cannot have that parent,
2126 -- e.g. if the user writes
2127 -- r { x = e } :: T
2128 -- where T does not have field x.
2129 pickParent :: RecSelParent
2130 -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
2131 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
2132 pickParent p (upd, xs)
2133 = case lookup p xs of
2134 -- Phew! The parent is valid for this field.
2135 -- Previously ambiguous fields must be marked as
2136 -- used now that we know which one is meant, but
2137 -- unambiguous ones shouldn't be recorded again
2138 -- (giving duplicate deprecation warnings).
2139 Just gre -> do { unless (null (tail xs)) $ do
2140 let L loc _ = hsRecFieldLbl (unLoc upd)
2141 setSrcSpan loc $ addUsedGRE True gre
2142 ; lookupSelector (upd, gre_name gre) }
2143 -- The field doesn't belong to this parent, so report
2144 -- an error but keep going through all the fields
2145 Nothing -> do { addErrTc (fieldNotInType p
2146 (unLoc (hsRecUpdFieldRdr (unLoc upd))))
2147 ; lookupSelector (upd, gre_name (snd (head xs))) }
2148
2149 -- Given a (field update, selector name) pair, look up the
2150 -- selector to give a field update with an unambiguous Id
2151 lookupSelector :: (LHsRecUpdField Name, Name)
2152 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
2153 lookupSelector (L l upd, n)
2154 = do { i <- tcLookupId n
2155 ; let L loc af = hsRecFieldLbl upd
2156 lbl = rdrNameAmbiguousFieldOcc af
2157 ; return $ L l upd { hsRecFieldLbl
2158 = L loc (Unambiguous (L loc lbl) i) } }
2159
2160
2161 -- Extract the outermost TyCon of a type, if there is one; for
2162 -- data families this is the representation tycon (because that's
2163 -- where the fields live).
2164 tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
2165 tyConOf fam_inst_envs ty0
2166 = case tcSplitTyConApp_maybe ty of
2167 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
2168 Nothing -> Nothing
2169 where
2170 (_, _, ty) = tcSplitSigmaTy ty0
2171
2172 -- Variant of tyConOf that works for ExpTypes
2173 tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
2174 tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
2175
2176 -- For an ambiguous record field, find all the candidate record
2177 -- selectors (as GlobalRdrElts) and their parents.
2178 lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
2179 lookupParents rdr
2180 = do { env <- getGlobalRdrEnv
2181 ; let gres = lookupGRE_RdrName rdr env
2182 ; mapM lookupParent gres }
2183 where
2184 lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
2185 lookupParent gre = do { id <- tcLookupId (gre_name gre)
2186 ; if isRecordSelector id
2187 then return (recordSelectorTyCon id, gre)
2188 else failWithTc (notSelector (gre_name gre)) }
2189
2190 -- A type signature on the argument of an ambiguous record selector or
2191 -- the record expression in an update must be "obvious", i.e. the
2192 -- outermost constructor ignoring parentheses.
2193 obviousSig :: HsExpr Name -> Maybe (LHsSigWcType Name)
2194 obviousSig (ExprWithTySig _ ty) = Just ty
2195 obviousSig (HsPar p) = obviousSig (unLoc p)
2196 obviousSig _ = Nothing
2197
2198
2199 {-
2200 Game plan for record bindings
2201 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2202 1. Find the TyCon for the bindings, from the first field label.
2203
2204 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
2205
2206 For each binding field = value
2207
2208 3. Instantiate the field type (from the field label) using the type
2209 envt from step 2.
2210
2211 4 Type check the value using tcArg, passing the field type as
2212 the expected argument type.
2213
2214 This extends OK when the field types are universally quantified.
2215 -}
2216
2217 tcRecordBinds
2218 :: ConLike
2219 -> [TcType] -- Expected type for each field
2220 -> HsRecordBinds Name
2221 -> TcM (HsRecordBinds TcId)
2222
2223 tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
2224 = do { mb_binds <- mapM do_bind rbinds
2225 ; return (HsRecFields (catMaybes mb_binds) dd) }
2226 where
2227 fields = map flLabel $ conLikeFieldLabels con_like
2228 flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
2229
2230 do_bind :: LHsRecField Name (LHsExpr Name)
2231 -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId)))
2232 do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
2233 , hsRecFieldArg = rhs }))
2234
2235 = do { mb <- tcRecordField con_like flds_w_tys f rhs
2236 ; case mb of
2237 Nothing -> return Nothing
2238 Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
2239 , hsRecFieldArg = rhs' }))) }
2240
2241 tcRecordUpd
2242 :: ConLike
2243 -> [TcType] -- Expected type for each field
2244 -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
2245 -> TcM [LHsRecUpdField TcId]
2246
2247 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
2248 where
2249 flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys
2250
2251 do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId))
2252 do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
2253 , hsRecFieldArg = rhs }))
2254 = do { let lbl = rdrNameAmbiguousFieldOcc af
2255 sel_id = selectorAmbiguousFieldOcc af
2256 f = L loc (FieldOcc (L loc lbl) (idName sel_id))
2257 ; mb <- tcRecordField con_like flds_w_tys f rhs
2258 ; case mb of
2259 Nothing -> return Nothing
2260 Just (f', rhs') ->
2261 return (Just
2262 (L l (fld { hsRecFieldLbl
2263 = L loc (Unambiguous (L loc lbl)
2264 (selectorFieldOcc (unLoc f')))
2265 , hsRecFieldArg = rhs' }))) }
2266
2267 tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name
2268 -> TcM (Maybe (LFieldOcc Id, LHsExpr Id))
2269 tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
2270 | Just field_ty <- assocMaybe flds_w_tys field_lbl
2271 = addErrCtxt (fieldCtxt field_lbl) $
2272 do { rhs' <- tcPolyExprNC rhs field_ty
2273 ; let field_id = mkUserLocal (nameOccName sel_name)
2274 (nameUnique sel_name)
2275 field_ty loc
2276 -- Yuk: the field_id has the *unique* of the selector Id
2277 -- (so we can find it easily)
2278 -- but is a LocalId with the appropriate type of the RHS
2279 -- (so the desugarer knows the type of local binder to make)
2280 ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
2281 | otherwise
2282 = do { addErrTc (badFieldCon con_like field_lbl)
2283 ; return Nothing }
2284 where
2285 field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
2286
2287
2288 checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM ()
2289 checkMissingFields con_like rbinds
2290 | null field_labels -- Not declared as a record;
2291 -- But C{} is still valid if no strict fields
2292 = if any isBanged field_strs then
2293 -- Illegal if any arg is strict
2294 addErrTc (missingStrictFields con_like [])
2295 else
2296 return ()
2297
2298 | otherwise = do -- A record
2299 unless (null missing_s_fields)
2300 (addErrTc (missingStrictFields con_like missing_s_fields))
2301
2302 warn <- woptM Opt_WarnMissingFields
2303 unless (not (warn && notNull missing_ns_fields))
2304 (warnTc (Reason Opt_WarnMissingFields) True
2305 (missingFields con_like missing_ns_fields))
2306
2307 where
2308 missing_s_fields
2309 = [ flLabel fl | (fl, str) <- field_info,
2310 isBanged str,
2311 not (fl `elemField` field_names_used)
2312 ]
2313 missing_ns_fields
2314 = [ flLabel fl | (fl, str) <- field_info,
2315 not (isBanged str),
2316 not (fl `elemField` field_names_used)
2317 ]
2318
2319 field_names_used = hsRecFields rbinds
2320 field_labels = conLikeFieldLabels con_like
2321
2322 field_info = zipEqual "missingFields"
2323 field_labels
2324 field_strs
2325
2326 field_strs = conLikeImplBangs con_like
2327
2328 fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
2329
2330 {-
2331 ************************************************************************
2332 * *
2333 \subsection{Errors and contexts}
2334 * *
2335 ************************************************************************
2336
2337 Boring and alphabetical:
2338 -}
2339
2340 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
2341 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
2342
2343 exprCtxt :: LHsExpr Name -> SDoc
2344 exprCtxt expr
2345 = hang (text "In the expression:") 2 (ppr expr)
2346
2347 fieldCtxt :: FieldLabelString -> SDoc
2348 fieldCtxt field_name
2349 = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
2350
2351 addFunResCtxt :: Bool -- There is at least one argument
2352 -> HsExpr Name -> TcType -> ExpRhoType
2353 -> TcM a -> TcM a
2354 -- When we have a mis-match in the return type of a function
2355 -- try to give a helpful message about too many/few arguments
2356 --
2357 -- Used for naked variables too; but with has_args = False
2358 addFunResCtxt has_args fun fun_res_ty env_ty
2359 = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)
2360 -- NB: use a landmark error context, so that an empty context
2361 -- doesn't suppress some more useful context
2362 where
2363 mk_msg
2364 = do { mb_env_ty <- readExpType_maybe env_ty
2365 -- by the time the message is rendered, the ExpType
2366 -- will be filled in (except if we're debugging)
2367 ; fun_res' <- zonkTcType fun_res_ty
2368 ; env' <- case mb_env_ty of
2369 Just env_ty -> zonkTcType env_ty
2370 Nothing ->
2371 do { dumping <- doptM Opt_D_dump_tc_trace
2372 ; MASSERT( dumping )
2373 ; newFlexiTyVarTy liftedTypeKind }
2374 ; let (_, _, fun_tau) = tcSplitSigmaTy fun_res'
2375 (_, _, env_tau) = tcSplitSigmaTy env'
2376 (args_fun, res_fun) = tcSplitFunTys fun_tau
2377 (args_env, res_env) = tcSplitFunTys env_tau
2378 n_fun = length args_fun
2379 n_env = length args_env
2380 info | n_fun == n_env = Outputable.empty
2381 | n_fun > n_env
2382 , not_fun res_env
2383 = text "Probable cause:" <+> quotes (ppr fun)
2384 <+> text "is applied to too few arguments"
2385
2386 | has_args
2387 , not_fun res_fun
2388 = text "Possible cause:" <+> quotes (ppr fun)
2389 <+> text "is applied to too many arguments"
2390
2391 | otherwise
2392 = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args!
2393 ; return info }
2394 where
2395 not_fun ty -- ty is definitely not an arrow type,
2396 -- and cannot conceivably become one
2397 = case tcSplitTyConApp_maybe ty of
2398 Just (tc, _) -> isAlgTyCon tc
2399 Nothing -> False
2400
2401 badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
2402 badFieldTypes prs
2403 = hang (text "Record update for insufficiently polymorphic field"
2404 <> plural prs <> colon)
2405 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
2406
2407 badFieldsUpd
2408 :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon
2409 -> [ConLike] -- Data cons of the type which the first field name belongs to
2410 -> SDoc
2411 badFieldsUpd rbinds data_cons
2412 = hang (text "No constructor has all these fields:")
2413 2 (pprQuotedList conflictingFields)
2414 -- See Note [Finding the conflicting fields]
2415 where
2416 -- A (preferably small) set of fields such that no constructor contains
2417 -- all of them. See Note [Finding the conflicting fields]
2418 conflictingFields = case nonMembers of
2419 -- nonMember belongs to a different type.
2420 (nonMember, _) : _ -> [aMember, nonMember]
2421 [] -> let
2422 -- All of rbinds belong to one type. In this case, repeatedly add
2423 -- a field to the set until no constructor contains the set.
2424
2425 -- Each field, together with a list indicating which constructors
2426 -- have all the fields so far.
2427 growingSets :: [(FieldLabelString, [Bool])]
2428 growingSets = scanl1 combine membership
2429 combine (_, setMem) (field, fldMem)
2430 = (field, zipWith (&&) setMem fldMem)
2431 in
2432 -- Fields that don't change the membership status of the set
2433 -- are redundant and can be dropped.
2434 map (fst . head) $ groupBy ((==) `on` snd) growingSets
2435
2436 aMember = ASSERT( not (null members) ) fst (head members)
2437 (members, nonMembers) = partition (or . snd) membership
2438
2439 -- For each field, which constructors contain the field?
2440 membership :: [(FieldLabelString, [Bool])]
2441 membership = sortMembership $
2442 map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
2443 map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
2444
2445 fieldLabelSets :: [Set.Set FieldLabelString]
2446 fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
2447
2448 -- Sort in order of increasing number of True, so that a smaller
2449 -- conflicting set can be found.
2450 sortMembership =
2451 map snd .
2452 sortBy (compare `on` fst) .
2453 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
2454
2455 countTrue = count id
2456
2457 {-
2458 Note [Finding the conflicting fields]
2459 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2460 Suppose we have
2461 data A = A {a0, a1 :: Int}
2462 | B {b0, b1 :: Int}
2463 and we see a record update
2464 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
2465 Then we'd like to find the smallest subset of fields that no
2466 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
2467 We don't really want to report that no constructor has all of
2468 {a0,a1,b0,b1}, because when there are hundreds of fields it's
2469 hard to see what was really wrong.
2470
2471 We may need more than two fields, though; eg
2472 data T = A { x,y :: Int, v::Int }
2473 | B { y,z :: Int, v::Int }
2474 | C { z,x :: Int, v::Int }
2475 with update
2476 r { x=e1, y=e2, z=e3 }, we
2477
2478 Finding the smallest subset is hard, so the code here makes
2479 a decent stab, no more. See Trac #7989.
2480 -}
2481
2482 naughtyRecordSel :: RdrName -> SDoc
2483 naughtyRecordSel sel_id
2484 = text "Cannot use record selector" <+> quotes (ppr sel_id) <+>
2485 text "as a function due to escaped type variables" $$
2486 text "Probable fix: use pattern-matching syntax instead"
2487
2488 notSelector :: Name -> SDoc
2489 notSelector field
2490 = hsep [quotes (ppr field), text "is not a record selector"]
2491
2492 mixedSelectors :: [Id] -> [Id] -> SDoc
2493 mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
2494 = ptext
2495 (sLit "Cannot use a mixture of pattern synonym and record selectors") $$
2496 text "Record selectors defined by"
2497 <+> quotes (ppr (tyConName rep_dc))
2498 <> text ":"
2499 <+> pprWithCommas ppr data_sels $$
2500 text "Pattern synonym selectors defined by"
2501 <+> quotes (ppr (patSynName rep_ps))
2502 <> text ":"
2503 <+> pprWithCommas ppr pat_syn_sels
2504 where
2505 RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
2506 RecSelData rep_dc = recordSelectorTyCon dc_rep_id
2507 mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"
2508
2509
2510 missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
2511 missingStrictFields con fields
2512 = header <> rest
2513 where
2514 rest | null fields = Outputable.empty -- Happens for non-record constructors
2515 -- with strict fields
2516 | otherwise = colon <+> pprWithCommas ppr fields
2517
2518 header = text "Constructor" <+> quotes (ppr con) <+>
2519 text "does not have the required strict field(s)"
2520
2521 missingFields :: ConLike -> [FieldLabelString] -> SDoc
2522 missingFields con fields
2523 = text "Fields of" <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
2524 <+> pprWithCommas ppr fields
2525
2526 -- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args))
2527
2528 noPossibleParents :: [LHsRecUpdField Name] -> SDoc
2529 noPossibleParents rbinds
2530 = hang (text "No type has all these fields:")
2531 2 (pprQuotedList fields)
2532 where
2533 fields = map (hsRecFieldLbl . unLoc) rbinds
2534
2535 badOverloadedUpdate :: SDoc
2536 badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"
2537
2538 fieldNotInType :: RecSelParent -> RdrName -> SDoc
2539 fieldNotInType p rdr
2540 = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr
2541
2542 {-
2543 ************************************************************************
2544 * *
2545 \subsection{Static Pointers}
2546 * *
2547 ************************************************************************
2548 -}
2549
2550 -- | A data type to describe why a variable is not closed.
2551 data NotClosedReason = NotLetBoundReason
2552 | NotTypeClosed VarSet
2553 | NotClosed Name NotClosedReason
2554
2555 -- | Checks if the given name is closed and emits an error if not.
2556 --
2557 -- See Note [Not-closed error messages].
2558 checkClosedInStaticForm :: Name -> TcM ()
2559 checkClosedInStaticForm name = do
2560 type_env <- getLclTypeEnv
2561 case checkClosed type_env name of
2562 Nothing -> return ()
2563 Just reason -> addErrTc $ explain name reason
2564 where
2565 -- See Note [Checking closedness].
2566 checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
2567 checkClosed type_env n = checkLoop type_env (unitNameSet n) n
2568
2569 checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
2570 checkLoop type_env visited n = do
2571 -- The @visited@ set is an accumulating parameter that contains the set of
2572 -- visited nodes, so we avoid repeating cycles in the traversal.
2573 case lookupNameEnv type_env n of
2574 Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
2575 ClosedLet -> Nothing
2576 NotLetBound -> Just NotLetBoundReason
2577 NonClosedLet fvs type_closed -> listToMaybe $
2578 -- Look for a non-closed variable in fvs
2579 [ NotClosed n' reason
2580 | n' <- nameSetElemsStable fvs
2581 , not (elemNameSet n' visited)
2582 , Just reason <- [checkLoop type_env (extendNameSet visited n') n']
2583 ] ++
2584 if type_closed then
2585 []
2586 else
2587 -- We consider non-let-bound variables easier to figure out than
2588 -- non-closed types, so we report non-closed types to the user
2589 -- only if we cannot spot the former.
2590 [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
2591 -- The binding is closed.
2592 _ -> Nothing
2593
2594 -- Converts a reason into a human-readable sentence.
2595 --
2596 -- @explain name reason@ starts with
2597 --
2598 -- "<name> is used in a static form but it is not closed because it"
2599 --
2600 -- and then follows a list of causes. For each id in the path, the text
2601 --
2602 -- "uses <id> which"
2603 --
2604 -- is appended, yielding something like
2605 --
2606 -- "uses <id> which uses <id1> which uses <id2> which"
2607 --
2608 -- until the end of the path is reached, which is reported as either
2609 --
2610 -- "is not let-bound"
2611 --
2612 -- when the final node is not let-bound, or
2613 --
2614 -- "has a non-closed type because it contains the type variables:
2615 -- v1, v2, v3"
2616 --
2617 -- when the final node has a non-closed type.
2618 --
2619 explain :: Name -> NotClosedReason -> SDoc
2620 explain name reason =
2621 quotes (ppr name) <+> text "is used in a static form but it is not closed"
2622 <+> text "because it"
2623 $$
2624 sep (causes reason)
2625
2626 causes :: NotClosedReason -> [SDoc]
2627 causes NotLetBoundReason = [text "is not let-bound."]
2628 causes (NotTypeClosed vs) =
2629 [ text "has a non-closed type because it contains the"
2630 , text "type variables:" <+>
2631 pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))
2632 ]
2633 causes (NotClosed n reason) =
2634 let msg = text "uses" <+> quotes (ppr n) <+> text "which"
2635 in case reason of
2636 NotClosed _ _ -> msg : causes reason
2637 _ -> let (xs0, xs1) = splitAt 1 $ causes reason
2638 in fmap (msg <+>) xs0 ++ xs1
2639
2640 -- Note [Not-closed error messages]
2641 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2642 --
2643 -- When variables in a static form are not closed, we go through the trouble
2644 -- of explaining why they aren't.
2645 --
2646 -- Thus, the following program
2647 --
2648 -- > {-# LANGUAGE StaticPointers #-}
2649 -- > module M where
2650 -- >
2651 -- > f x = static g
2652 -- > where
2653 -- > g = h
2654 -- > h = x
2655 --
2656 -- produces the error
2657 --
2658 -- 'g' is used in a static form but it is not closed because it
2659 -- uses 'h' which uses 'x' which is not let-bound.
2660 --
2661 -- And a program like
2662 --
2663 -- > {-# LANGUAGE StaticPointers #-}
2664 -- > module M where
2665 -- >
2666 -- > import Data.Typeable
2667 -- > import GHC.StaticPtr
2668 -- >
2669 -- > f :: Typeable a => a -> StaticPtr TypeRep
2670 -- > f x = const (static (g undefined)) (h x)
2671 -- > where
2672 -- > g = h
2673 -- > h = typeOf
2674 --
2675 -- produces the error
2676 --
2677 -- 'g' is used in a static form but it is not closed because it
2678 -- uses 'h' which has a non-closed type because it contains the
2679 -- type variables: 'a'
2680 --
2681
2682 -- Note [Checking closedness]
2683 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
2684 --
2685 -- @checkClosed@ checks if a binding is closed and returns a reason if it is
2686 -- not.
2687 --
2688 -- The bindings define a graph where the nodes are ids, and there is an edge
2689 -- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
2690 -- variables.
2691 --
2692 -- When @n@ is not closed, it has to exist in the graph some node reachable
2693 -- from @n@ that it is not a let-bound variable or that it has a non-closed
2694 -- type. Thus, the "reason" is a path from @n@ to this offending node.
2695 --
2696 -- When @n@ is not closed, we traverse the graph reachable from @n@ to build
2697 -- the reason.
2698 --