Implement unboxed sum primitive type
[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 TysPrim ( tYPE )
58 import TcEvidence
59 import VarSet
60 import TysWiredIn
61 import TysPrim( intPrimTy )
62 import PrimOp( tagToEnumKey )
63 import PrelNames
64 import MkId ( proxyHashId )
65 import DynFlags
66 import SrcLoc
67 import Util
68 import VarEnv ( emptyTidyEnv )
69 import ListSetOps
70 import Maybes
71 import Outputable
72 import FastString
73 import Control.Monad
74 import Class(classTyCon)
75 import UniqFM ( nonDetEltsUFM )
76 import qualified GHC.LanguageExtensions as LangExt
77
78 import Data.Function
79 import Data.List
80 import Data.Either
81 import qualified Data.Set as Set
82
83 {-
84 ************************************************************************
85 * *
86 \subsection{Main wrappers}
87 * *
88 ************************************************************************
89 -}
90
91 tcPolyExpr, tcPolyExprNC
92 :: LHsExpr Name -- Expression to type check
93 -> TcSigmaType -- Expected type (could be a polytype)
94 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
95
96 -- tcPolyExpr is a convenient place (frequent but not too frequent)
97 -- place to add context information.
98 -- The NC version does not do so, usually because the caller wants
99 -- to do so himself.
100
101 tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)
102 tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)
103
104 -- these versions take an ExpType
105 tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId)
106 tc_poly_expr expr res_ty
107 = addExprErrCtxt expr $
108 do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
109
110 tc_poly_expr_nc (L loc expr) res_ty
111 = do { traceTc "tcPolyExprNC" (ppr res_ty)
112 ; (wrap, expr')
113 <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
114 setSrcSpan loc $
115 -- NB: setSrcSpan *after* skolemising, so we get better
116 -- skolem locations
117 tcExpr expr res_ty
118 ; return $ L loc (mkHsWrap wrap expr') }
119
120 ---------------
121 tcMonoExpr, tcMonoExprNC
122 :: LHsExpr Name -- Expression to type check
123 -> ExpRhoType -- Expected type
124 -- Definitely no foralls at the top
125 -> TcM (LHsExpr TcId)
126
127 tcMonoExpr expr res_ty
128 = addErrCtxt (exprCtxt expr) $
129 tcMonoExprNC expr res_ty
130
131 tcMonoExprNC (L loc expr) res_ty
132 = setSrcSpan loc $
133 do { expr' <- tcExpr expr res_ty
134 ; return (L loc expr') }
135
136 ---------------
137 tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM ( LHsExpr TcId
138 , TcSigmaType )
139 -- Infer a *sigma*-type.
140 tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)
141
142 tcInferSigmaNC (L loc expr)
143 = setSrcSpan loc $
144 do { (expr', sigma) <- tcInfer (tcExpr expr)
145 ; return (L loc expr', sigma) }
146
147 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
148 -- Infer a *rho*-type. The return type is always (shallowly) instantiated.
149 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
150
151 tcInferRhoNC expr
152 = do { (expr', sigma) <- tcInferSigmaNC expr
153 ; (wrap, rho) <- topInstantiate (exprCtOrigin (unLoc expr)) sigma
154 ; return (mkLHsWrap wrap expr', rho) }
155
156
157 {-
158 ************************************************************************
159 * *
160 tcExpr: the main expression typechecker
161 * *
162 ************************************************************************
163
164 NB: The res_ty is always deeply skolemised.
165 -}
166
167 tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
168 tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
169 tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty
170
171 tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty
172 tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
173
174 tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit
175 ; tcWrapResult e (HsLit lit) lit_ty res_ty }
176
177 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
178 ; return (HsPar expr') }
179
180 tcExpr (HsSCC src lbl expr) res_ty
181 = do { expr' <- tcMonoExpr expr res_ty
182 ; return (HsSCC src lbl expr') }
183
184 tcExpr (HsTickPragma src info srcInfo expr) res_ty
185 = do { expr' <- tcMonoExpr expr res_ty
186 ; return (HsTickPragma src info srcInfo expr') }
187
188 tcExpr (HsCoreAnn src lbl expr) res_ty
189 = do { expr' <- tcMonoExpr expr res_ty
190 ; return (HsCoreAnn src lbl expr') }
191
192 tcExpr (HsOverLit lit) res_ty
193 = do { lit' <- newOverloadedLit lit res_ty
194 ; return (HsOverLit lit') }
195
196 tcExpr (NegApp expr neg_expr) res_ty
197 = do { (expr', neg_expr')
198 <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
199 \[arg_ty] ->
200 tcMonoExpr expr (mkCheckExpType arg_ty)
201 ; return (NegApp expr' neg_expr') }
202
203 tcExpr e@(HsIPVar x) res_ty
204 = do { {- Implicit parameters must have a *tau-type* not a
205 type scheme. We enforce this by creating a fresh
206 type variable as its type. (Because res_ty may not
207 be a tau-type.) -}
208 ip_ty <- newOpenFlexiTyVarTy
209 ; let ip_name = mkStrLitTy (hsIPNameFS x)
210 ; ipClass <- tcLookupClass ipClassName
211 ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
212 ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
213 ip_ty res_ty }
214 where
215 -- Coerces a dictionary for `IP "x" t` into `t`.
216 fromDict ipClass x ty = HsWrap $ mkWpCastR $
217 unwrapIP $ mkClassPred ipClass [x,ty]
218 origin = IPOccOrigin x
219
220 tcExpr e@(HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels]
221 = do { isLabelClass <- tcLookupClass isLabelClassName
222 ; alpha <- newOpenFlexiTyVarTy
223 ; let lbl = mkStrLitTy l
224 pred = mkClassPred isLabelClass [lbl, alpha]
225 ; loc <- getSrcSpanM
226 ; var <- emitWantedEvVar origin pred
227 ; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
228 (HsVar (L loc proxyHashId)))
229 tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg
230 ; tcWrapResult e tm alpha res_ty }
231 where
232 -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`.
233 fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred
234 origin = OverLabelOrigin l
235
236 tcExpr (HsLam match) res_ty
237 = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
238 ; return (mkHsWrap wrap (HsLam match')) }
239 where
240 match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
241 herald = sep [ text "The lambda expression" <+>
242 quotes (pprSetDepth (PartWay 1) $
243 pprMatches match),
244 -- The pprSetDepth makes the abstraction print briefly
245 text "has"]
246
247 tcExpr e@(HsLamCase matches) res_ty
248 = do { (matches', wrap)
249 <- tcMatchLambda msg match_ctxt matches res_ty
250 -- The laziness annotation is because we don't want to fail here
251 -- if there are multiple arguments
252 ; return (mkHsWrap wrap $ HsLamCase matches') }
253 where
254 msg = sep [ text "The function" <+> quotes (ppr e)
255 , text "requires"]
256 match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
257
258 tcExpr e@(ExprWithTySig expr sig_ty) res_ty
259 = do { let loc = getLoc (hsSigWcType sig_ty)
260 ; sig_info <- checkNoErrs $ -- Avoid error cascade
261 tcUserTypeSig loc sig_ty Nothing
262 ; (expr', poly_ty) <- tcExprSig expr sig_info
263 ; let expr'' = ExprWithTySigOut expr' sig_ty
264 ; tcWrapResult e expr'' poly_ty res_ty }
265
266 {-
267 Note [Type-checking overloaded labels]
268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
269 Recall that (in GHC.OverloadedLabels) we have
270
271 class IsLabel (x :: Symbol) a where
272 fromLabel :: Proxy# x -> a
273
274 When we see an overloaded label like `#foo`, we generate a fresh
275 variable `alpha` for the type and emit an `IsLabel "foo" alpha`
276 constraint. Because the `IsLabel` class has a single method, it is
277 represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
278 `Proxy# "foo" -> alpha` (just like for implicit parameters). We then
279 apply it to `proxy#` of type `Proxy# "foo"`.
280
281 That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
282 -}
283
284
285 {-
286 ************************************************************************
287 * *
288 Infix operators and sections
289 * *
290 ************************************************************************
291
292 Note [Left sections]
293 ~~~~~~~~~~~~~~~~~~~~
294 Left sections, like (4 *), are equivalent to
295 \ x -> (*) 4 x,
296 or, if PostfixOperators is enabled, just
297 (*) 4
298 With PostfixOperators we don't actually require the function to take
299 two arguments at all. For example, (x `not`) means (not x); you get
300 postfix operators! Not Haskell 98, but it's less work and kind of
301 useful.
302
303 Note [Typing rule for ($)]
304 ~~~~~~~~~~~~~~~~~~~~~~~~~~
305 People write
306 runST $ blah
307 so much, where
308 runST :: (forall s. ST s a) -> a
309 that I have finally given in and written a special type-checking
310 rule just for saturated appliations of ($).
311 * Infer the type of the first argument
312 * Decompose it; should be of form (arg2_ty -> res_ty),
313 where arg2_ty might be a polytype
314 * Use arg2_ty to typecheck arg2
315
316 Note [Typing rule for seq]
317 ~~~~~~~~~~~~~~~~~~~~~~~~~~
318 We want to allow
319 x `seq` (# p,q #)
320 which suggests this type for seq:
321 seq :: forall (a:*) (b:Open). a -> b -> b,
322 with (b:Open) meaning that be can be instantiated with an unboxed
323 tuple. The trouble is that this might accept a partially-applied
324 'seq', and I'm just not certain that would work. I'm only sure it's
325 only going to work when it's fully applied, so it turns into
326 case x of _ -> (# p,q #)
327
328 So it seems more uniform to treat 'seq' as it it was a language
329 construct.
330
331 See also Note [seqId magic] in MkId
332 -}
333
334 tcExpr expr@(OpApp arg1 op fix arg2) res_ty
335 | (L loc (HsVar (L lv op_name))) <- op
336 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
337 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
338 ; let arg2_exp_ty = res_ty
339 ; arg1' <- tcArg op arg1 arg1_ty 1
340 ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
341 tc_poly_expr_nc arg2 arg2_exp_ty
342 ; arg2_ty <- readExpType arg2_exp_ty
343 ; op_id <- tcLookupId op_name
344 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty])
345 (HsVar (L lv op_id)))
346 ; return $ OpApp arg1' op' fix arg2' }
347
348 | (L loc (HsVar (L lv op_name))) <- op
349 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
350 = do { traceTc "Application rule" (ppr op)
351 ; (arg1', arg1_ty) <- tcInferSigma arg1
352
353 ; let doc = text "The first argument of ($) takes"
354 orig1 = exprCtOrigin (unLoc arg1)
355 ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
356 matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
357
358 -- We have (arg1 $ arg2)
359 -- So: arg1_ty = arg2_ty -> op_res_ty
360 -- where arg2_sigma maybe polymorphic; that's the point
361
362 ; arg2' <- tcArg op arg2 arg2_sigma 2
363
364 -- Make sure that the argument type has kind '*'
365 -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
366 -- Eg we do not want to allow (D# $ 4.0#) Trac #5570
367 -- (which gives a seg fault)
368 --
369 -- The *result* type can have any kind (Trac #8739),
370 -- so we don't need to check anything for that
371 ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind
372 -- ignore the evidence. arg2_sigma must have type * or #,
373 -- because we know arg2_sigma -> or_res_ty is well-kinded
374 -- (because otherwise matchActualFunTys would fail)
375 -- There's no possibility here of, say, a kind family reducing to *.
376
377 ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
378 -- op_res -> res
379
380 ; op_id <- tcLookupId op_name
381 ; res_ty <- readExpType res_ty
382 ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
383 , arg2_sigma
384 , res_ty])
385 (HsVar (L lv op_id)))
386 -- arg1' :: arg1_ty
387 -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
388 -- wrap_res :: op_res_ty "->" res_ty
389 -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
390
391 -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
392 wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty
393 <.> wrap_arg1
394
395 ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
396
397 | (L loc (HsRecFld (Ambiguous lbl _))) <- op
398 , Just sig_ty <- obviousSig (unLoc arg1)
399 -- See Note [Disambiguating record fields]
400 = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
401 ; sel_name <- disambiguateSelector lbl sig_tc_ty
402 ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
403 ; tcExpr (OpApp arg1 op' fix arg2) res_ty
404 }
405
406 | otherwise
407 = do { traceTc "Non Application rule" (ppr op)
408 ; (wrap, op', [Left arg1', Left arg2'])
409 <- tcApp (Just $ mk_op_msg op)
410 op [Left arg1, Left arg2] res_ty
411 ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
412
413 -- Right sections, equivalent to \ x -> x `op` expr, or
414 -- \ x -> op x expr
415
416 tcExpr expr@(SectionR op arg2) res_ty
417 = do { (op', op_ty) <- tcInferFun op
418 ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
419 matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) 2 op_ty
420 ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
421 (mkFunTy arg1_ty op_res_ty) res_ty
422 ; arg2' <- tcArg op arg2 arg2_ty 2
423 ; return ( mkHsWrap wrap_res $
424 SectionR (mkLHsWrap wrap_fun op') arg2' ) }
425
426 tcExpr expr@(SectionL arg1 op) res_ty
427 = do { (op', op_ty) <- tcInferFun op
428 ; dflags <- getDynFlags -- Note [Left sections]
429 ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
430 | otherwise = 2
431
432 ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
433 <- matchActualFunTys (mk_op_msg op) SectionOrigin (Just op)
434 n_reqd_args op_ty
435 ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
436 (mkFunTys arg_tys op_res_ty) res_ty
437 ; arg1' <- tcArg op arg1 arg1_ty 1
438 ; return ( mkHsWrap wrap_res $
439 SectionL arg1' (mkLHsWrap wrap_fn op') ) }
440
441 tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
442 | all tupArgPresent tup_args
443 = do { let arity = length tup_args
444 tup_tc = tupleTyCon boxity arity
445 ; res_ty <- expTypeToType res_ty
446 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
447 -- Unboxed tuples have RuntimeRep vars, which we
448 -- don't care about here
449 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
450 ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
451 Boxed -> arg_tys
452 ; tup_args1 <- tcTupArgs tup_args arg_tys'
453 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
454
455 | otherwise
456 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
457 do { let arity = length tup_args
458
459 ; arg_tys <- case boxity of
460 { Boxed -> newFlexiTyVarTys arity liftedTypeKind
461 ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
462 ; let actual_res_ty
463 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
464 (mkTupleTy boxity arg_tys)
465
466 ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
467 (Just expr)
468 actual_res_ty res_ty
469
470 -- Handle tuple sections where
471 ; tup_args1 <- tcTupArgs tup_args arg_tys
472
473 ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
474
475 tcExpr (ExplicitSum alt arity expr _) res_ty
476 = do { let sum_tc = sumTyCon arity
477 ; res_ty <- expTypeToType res_ty
478 ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
479 ; -- Drop levity vars, we don't care about them here
480 let arg_tys' = drop arity arg_tys
481 ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))
482 ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') }
483
484 tcExpr (ExplicitList _ witness exprs) res_ty
485 = case witness of
486 Nothing -> do { res_ty <- expTypeToType res_ty
487 ; (coi, elt_ty) <- matchExpectedListTy res_ty
488 ; exprs' <- mapM (tc_elt elt_ty) exprs
489 ; return $
490 mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
491
492 Just fln -> do { ((exprs', elt_ty), fln')
493 <- tcSyntaxOp ListOrigin fln
494 [synKnownType intTy, SynList] res_ty $
495 \ [elt_ty] ->
496 do { exprs' <-
497 mapM (tc_elt elt_ty) exprs
498 ; return (exprs', elt_ty) }
499
500 ; return $ ExplicitList elt_ty (Just fln') exprs' }
501 where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
502
503 tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
504 = do { res_ty <- expTypeToType res_ty
505 ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
506 ; exprs' <- mapM (tc_elt elt_ty) exprs
507 ; return $
508 mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }
509 where
510 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
511
512 {-
513 ************************************************************************
514 * *
515 Let, case, if, do
516 * *
517 ************************************************************************
518 -}
519
520 tcExpr (HsLet (L l binds) expr) res_ty
521 = do { (binds', expr') <- tcLocalBinds binds $
522 tcMonoExpr expr res_ty
523 ; return (HsLet (L l binds') expr') }
524
525 tcExpr (HsCase scrut matches) res_ty
526 = do { -- We used to typecheck the case alternatives first.
527 -- The case patterns tend to give good type info to use
528 -- when typechecking the scrutinee. For example
529 -- case (map f) of
530 -- (x:xs) -> ...
531 -- will report that map is applied to too few arguments
532 --
533 -- But now, in the GADT world, we need to typecheck the scrutinee
534 -- first, to get type info that may be refined in the case alternatives
535 (scrut', scrut_ty) <- tcInferRho scrut
536
537 ; traceTc "HsCase" (ppr scrut_ty)
538 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
539 ; return (HsCase scrut' matches') }
540 where
541 match_ctxt = MC { mc_what = CaseAlt,
542 mc_body = tcBody }
543
544 tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
545 = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
546 ; res_ty <- tauifyExpType res_ty
547 -- Just like Note [Case branches must never infer a non-tau type]
548 -- in TcMatches (See #10619)
549
550 ; b1' <- tcMonoExpr b1 res_ty
551 ; b2' <- tcMonoExpr b2 res_ty
552 ; return (HsIf Nothing pred' b1' b2') }
553
554 tcExpr (HsIf (Just fun) pred b1 b2) res_ty
555 = do { ((pred', b1', b2'), fun')
556 <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
557 \ [pred_ty, b1_ty, b2_ty] ->
558 do { pred' <- tcPolyExpr pred pred_ty
559 ; b1' <- tcPolyExpr b1 b1_ty
560 ; b2' <- tcPolyExpr b2 b2_ty
561 ; return (pred', b1', b2') }
562 ; return (HsIf (Just fun') pred' b1' b2') }
563
564 tcExpr (HsMultiIf _ alts) res_ty
565 = do { res_ty <- if isSingleton alts
566 then return res_ty
567 else tauifyExpType res_ty
568 -- Just like TcMatches
569 -- Note [Case branches must never infer a non-tau type]
570
571 ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
572 ; res_ty <- readExpType res_ty
573 ; return (HsMultiIf res_ty alts') }
574 where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
575
576 tcExpr (HsDo do_or_lc stmts _) res_ty
577 = do { expr' <- tcDoStmts do_or_lc stmts res_ty
578 ; return expr' }
579
580 tcExpr (HsProc pat cmd) res_ty
581 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
582 ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
583
584 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
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 ; stWC <- tcg_static_wc <$> getGblEnv
609 ; updTcRef stWC (andWC lie)
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 = do { (fun, fun_ty) <- tcInferSigma fun
1180
1181 -- Zonk the function type carefully, to expose any polymorphism
1182 -- E.g. (( \(x::forall a. a->a). blah ) e)
1183 -- We can see the rank-2 type of the lambda in time to generalise e
1184 ; fun_ty' <- zonkTcType fun_ty
1185
1186 ; return (fun, fun_ty') }
1187
1188 ----------------
1189 -- | Type-check the arguments to a function, possibly including visible type
1190 -- applications
1191 tcArgs :: LHsExpr Name -- ^ The function itself (for err msgs only)
1192 -> TcSigmaType -- ^ the (uninstantiated) type of the function
1193 -> CtOrigin -- ^ the origin for the function's type
1194 -> [LHsExprArgIn] -- ^ the args
1195 -> SDoc -- ^ the herald for matchActualFunTys
1196 -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
1197 -- ^ (a wrapper for the function, the tc'd args, result type)
1198 tcArgs fun orig_fun_ty fun_orig orig_args herald
1199 = go [] 1 orig_fun_ty orig_args
1200 where
1201 orig_arity = length orig_args
1202
1203 go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
1204
1205 go acc_args n fun_ty (Right hs_ty_arg:args)
1206 = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
1207 -- wrap1 :: fun_ty "->" upsilon_ty
1208 ; case tcSplitForAllTy_maybe upsilon_ty of
1209 Just (tvb, inner_ty) ->
1210 do { let tv = binderVar tvb
1211 vis = binderArgFlag tvb
1212 kind = tyVarKind tv
1213 ; MASSERT2( vis == Specified
1214 , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr tvb
1215 , ppr inner_ty, pprTvBndr tv
1216 , ppr vis ]) )
1217 ; ty_arg <- tcHsTypeApp hs_ty_arg kind
1218 ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty
1219 ; (inner_wrap, args', res_ty)
1220 <- go acc_args (n+1) insted_ty args
1221 -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
1222 ; let inst_wrap = mkWpTyApps [ty_arg]
1223 ; return ( inner_wrap <.> inst_wrap <.> wrap1
1224 , Right hs_ty_arg : args'
1225 , res_ty ) }
1226 _ -> ty_app_err upsilon_ty hs_ty_arg }
1227
1228 go acc_args n fun_ty (Left arg : args)
1229 = do { (wrap, [arg_ty], res_ty)
1230 <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
1231 acc_args orig_arity
1232 -- wrap :: fun_ty "->" arg_ty -> res_ty
1233 ; arg' <- tcArg fun arg arg_ty n
1234 ; (inner_wrap, args', inner_res_ty)
1235 <- go (arg_ty : acc_args) (n+1) res_ty args
1236 -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
1237 ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap
1238 , Left arg' : args'
1239 , inner_res_ty ) }
1240
1241 ty_app_err ty arg
1242 = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty
1243 ; failWith $
1244 text "Cannot apply expression of type" <+> quotes (ppr ty) $$
1245 text "to a visible type argument" <+> quotes (ppr arg) }
1246
1247 ----------------
1248 tcArg :: LHsExpr Name -- The function (for error messages)
1249 -> LHsExpr Name -- Actual arguments
1250 -> TcRhoType -- expected arg type
1251 -> Int -- # of argument
1252 -> TcM (LHsExpr TcId) -- Resulting argument
1253 tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $
1254 tcPolyExprNC arg ty
1255
1256 ----------------
1257 tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
1258 tcTupArgs args tys
1259 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
1260 where
1261 go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
1262 go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
1263 ; return (L l (Present expr')) }
1264
1265 ---------------------------
1266 -- See TcType.SyntaxOpType also for commentary
1267 tcSyntaxOp :: CtOrigin
1268 -> SyntaxExpr Name
1269 -> [SyntaxOpType] -- ^ shape of syntax operator arguments
1270 -> ExpType -- ^ overall result type
1271 -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
1272 -> TcM (a, SyntaxExpr TcId)
1273 -- ^ Typecheck a syntax operator
1274 -- The operator is always a variable at this stage (i.e. renamer output)
1275 tcSyntaxOp orig expr arg_tys res_ty
1276 = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
1277
1278 -- | Slightly more general version of 'tcSyntaxOp' that allows the caller
1279 -- to specify the shape of the result of the syntax operator
1280 tcSyntaxOpGen :: CtOrigin
1281 -> SyntaxExpr Name
1282 -> [SyntaxOpType]
1283 -> SyntaxOpType
1284 -> ([TcSigmaType] -> TcM a)
1285 -> TcM (a, SyntaxExpr TcId)
1286 tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })
1287 arg_tys res_ty thing_inside
1288 = do { (expr, sigma) <- tcInferId op
1289 ; (result, expr_wrap, arg_wraps, res_wrap)
1290 <- tcSynArgA orig sigma arg_tys res_ty $
1291 thing_inside
1292 ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap expr
1293 , syn_arg_wraps = arg_wraps
1294 , syn_res_wrap = res_wrap }) }
1295
1296 tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other)
1297
1298 {-
1299 Note [tcSynArg]
1300 ~~~~~~~~~~~~~~~
1301 Because of the rich structure of SyntaxOpType, we must do the
1302 contra-/covariant thing when working down arrows, to get the
1303 instantiation vs. skolemisation decisions correct (and, more
1304 obviously, the orientation of the HsWrappers). We thus have
1305 two tcSynArgs.
1306 -}
1307
1308 -- works on "expected" types, skolemising where necessary
1309 -- See Note [tcSynArg]
1310 tcSynArgE :: CtOrigin
1311 -> TcSigmaType
1312 -> SyntaxOpType -- ^ shape it is expected to have
1313 -> ([TcSigmaType] -> TcM a) -- ^ check the arguments
1314 -> TcM (a, HsWrapper)
1315 -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
1316 tcSynArgE orig sigma_ty syn_ty thing_inside
1317 = do { (skol_wrap, (result, ty_wrapper))
1318 <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty ->
1319 go rho_ty syn_ty
1320 ; return (result, skol_wrap <.> ty_wrapper) }
1321 where
1322 go rho_ty SynAny
1323 = do { result <- thing_inside [rho_ty]
1324 ; return (result, idHsWrapper) }
1325
1326 go rho_ty SynRho -- same as SynAny, because we skolemise eagerly
1327 = do { result <- thing_inside [rho_ty]
1328 ; return (result, idHsWrapper) }
1329
1330 go rho_ty SynList
1331 = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
1332 ; result <- thing_inside [elt_ty]
1333 ; return (result, mkWpCastN list_co) }
1334
1335 go rho_ty (SynFun arg_shape res_shape)
1336 = do { ( ( ( (result, arg_ty, res_ty)
1337 , res_wrapper ) -- :: res_ty_out "->" res_ty
1338 , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out
1339 , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty
1340 <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $
1341 \ [arg_ty] res_ty ->
1342 do { arg_tc_ty <- expTypeToType arg_ty
1343 ; res_tc_ty <- expTypeToType res_ty
1344
1345 -- another nested arrow is too much for now,
1346 -- but I bet we'll never need this
1347 ; MASSERT2( case arg_shape of
1348 SynFun {} -> False;
1349 _ -> True
1350 , text "Too many nested arrows in SyntaxOpType" $$
1351 pprCtOrigin orig )
1352
1353 ; tcSynArgA orig arg_tc_ty [] arg_shape $
1354 \ arg_results ->
1355 tcSynArgE orig res_tc_ty res_shape $
1356 \ res_results ->
1357 do { result <- thing_inside (arg_results ++ res_results)
1358 ; return (result, arg_tc_ty, res_tc_ty) }}
1359
1360 ; return ( result
1361 , match_wrapper <.>
1362 mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
1363 arg_ty res_ty ) }
1364 where
1365 herald = text "This rebindable syntax expects a function with"
1366
1367 go rho_ty (SynType the_ty)
1368 = do { wrap <- tcSubTypeET orig the_ty rho_ty
1369 ; result <- thing_inside []
1370 ; return (result, wrap) }
1371
1372 -- works on "actual" types, instantiating where necessary
1373 -- See Note [tcSynArg]
1374 tcSynArgA :: CtOrigin
1375 -> TcSigmaType
1376 -> [SyntaxOpType] -- ^ argument shapes
1377 -> SyntaxOpType -- ^ result shape
1378 -> ([TcSigmaType] -> TcM a) -- ^ check the arguments
1379 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
1380 -- ^ returns a wrapper to be applied to the original function,
1381 -- wrappers to be applied to arguments
1382 -- and a wrapper to be applied to the overall expression
1383 tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
1384 = do { (match_wrapper, arg_tys, res_ty)
1385 <- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty
1386 -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
1387 ; ((result, res_wrapper), arg_wrappers)
1388 <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
1389 tc_syn_arg res_ty res_shape $ \ res_results ->
1390 thing_inside (arg_results ++ res_results)
1391 ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
1392 where
1393 herald = text "This rebindable syntax expects a function with"
1394
1395 tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
1396 -> ([TcSigmaType] -> TcM a)
1397 -> TcM (a, [HsWrapper])
1398 -- the wrappers are for arguments
1399 tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
1400 = do { ((result, arg_wraps), arg_wrap)
1401 <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results ->
1402 tc_syn_args_e arg_tys arg_shapes $ \ args_results ->
1403 thing_inside (arg1_results ++ args_results)
1404 ; return (result, arg_wrap : arg_wraps) }
1405 tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []
1406
1407 tc_syn_arg :: TcSigmaType -> SyntaxOpType
1408 -> ([TcSigmaType] -> TcM a)
1409 -> TcM (a, HsWrapper)
1410 -- the wrapper applies to the overall result
1411 tc_syn_arg res_ty SynAny thing_inside
1412 = do { result <- thing_inside [res_ty]
1413 ; return (result, idHsWrapper) }
1414 tc_syn_arg res_ty SynRho thing_inside
1415 = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty
1416 -- inst_wrap :: res_ty "->" rho_ty
1417 ; result <- thing_inside [rho_ty]
1418 ; return (result, inst_wrap) }
1419 tc_syn_arg res_ty SynList thing_inside
1420 = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
1421 -- inst_wrap :: res_ty "->" rho_ty
1422 ; (list_co, elt_ty) <- matchExpectedListTy rho_ty
1423 -- list_co :: [elt_ty] ~N rho_ty
1424 ; result <- thing_inside [elt_ty]
1425 ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
1426 tc_syn_arg _ (SynFun {}) _
1427 = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
1428 tc_syn_arg res_ty (SynType the_ty) thing_inside
1429 = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty
1430 ; result <- thing_inside []
1431 ; return (result, wrap) }
1432
1433 {-
1434 Note [Push result type in]
1435 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1436 Unify with expected result before type-checking the args so that the
1437 info from res_ty percolates to args. This is when we might detect a
1438 too-few args situation. (One can think of cases when the opposite
1439 order would give a better error message.)
1440 experimenting with putting this first.
1441
1442 Here's an example where it actually makes a real difference
1443
1444 class C t a b | t a -> b
1445 instance C Char a Bool
1446
1447 data P t a = forall b. (C t a b) => MkP b
1448 data Q t = MkQ (forall a. P t a)
1449
1450 f1, f2 :: Q Char;
1451 f1 = MkQ (MkP True)
1452 f2 = MkQ (MkP True :: forall a. P Char a)
1453
1454 With the change, f1 will type-check, because the 'Char' info from
1455 the signature is propagated into MkQ's argument. With the check
1456 in the other order, the extra signature in f2 is reqd.
1457
1458 ************************************************************************
1459 * *
1460 Expressions with a type signature
1461 expr :: type
1462 * *
1463 ********************************************************************* -}
1464
1465 tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType)
1466 tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
1467 = setSrcSpan loc $ -- Sets the location for the implication constraint
1468 do { (tv_prs, theta, tau) <- tcInstType (tcInstSigTyVars loc) poly_id
1469 ; given <- newEvVars theta
1470 ; let skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
1471 skol_tvs = map snd tv_prs
1472 ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $
1473 tcExtendTyVarEnv2 tv_prs $
1474 tcPolyExprNC expr tau
1475
1476 ; let poly_wrap = mkWpTyLams skol_tvs
1477 <.> mkWpLams given
1478 <.> mkWpLet ev_binds
1479 ; return (mkLHsWrap poly_wrap expr', idType poly_id) }
1480
1481 tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
1482 = setSrcSpan loc $ -- Sets the location for the implication constraint
1483 do { (tclvl, wanted, (expr', sig_inst))
1484 <- pushLevelAndCaptureConstraints $
1485 do { sig_inst <- tcInstSig sig
1486 ; expr' <- tcExtendTyVarEnv2 (sig_inst_skols sig_inst) $
1487 tcExtendTyVarEnv2 (sig_inst_wcs sig_inst) $
1488 tcPolyExprNC expr (sig_inst_tau sig_inst)
1489 ; return (expr', sig_inst) }
1490 -- See Note [Partial expression signatures]
1491 ; let tau = sig_inst_tau sig_inst
1492 infer_mode | null (sig_inst_theta sig_inst)
1493 , isNothing (sig_inst_wcx sig_inst)
1494 = ApplyMR
1495 | otherwise
1496 = NoRestrictions
1497 ; (qtvs, givens, ev_binds)
1498 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
1499 ; tau <- zonkTcType tau
1500 ; let inferred_theta = map evVarPred givens
1501 tau_tvs = tyCoVarsOfType tau
1502 ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta
1503 tau_tvs qtvs (Just sig_inst)
1504 ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau
1505 my_sigma = mkForAllTys binders (mkPhiTy my_theta tau)
1506 ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
1507 then return idHsWrapper -- Fast path; also avoids complaint when we infer
1508 -- an ambiguouse type and have AllowAmbiguousType
1509 -- e..g infer x :: forall a. F a -> Int
1510 else tcSubType_NC ExprSigCtxt inferred_sigma
1511 (mkCheckExpType my_sigma)
1512
1513 ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
1514 ; let poly_wrap = wrap
1515 <.> mkWpTyLams qtvs
1516 <.> mkWpLams givens
1517 <.> mkWpLet ev_binds
1518 ; return (mkLHsWrap poly_wrap expr', my_sigma) }
1519
1520
1521 {- Note [Partial expression signatures]
1522 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1523 Partial type signatures on expressions are easy to get wrong. But
1524 here is a guiding principile
1525 e :: ty
1526 should behave like
1527 let x :: ty
1528 x = e
1529 in x
1530
1531 So for partial signatures we apply the MR if no context is given. So
1532 e :: IO _ apply the MR
1533 e :: _ => IO _ do not apply the MR
1534 just like in TcBinds.decideGeneralisationPlan
1535
1536 This makes a difference (Trac #11670):
1537 peek :: Ptr a -> IO CLong
1538 peek ptr = peekElemOff undefined 0 :: _
1539 from (peekElemOff undefined 0) we get
1540 type: IO w
1541 constraints: Storable w
1542
1543 We must NOT try to generalise over 'w' because the signature specifies
1544 no constraints so we'll complain about not being able to solve
1545 Storable w. Instead, don't generalise; then _ gets instantiated to
1546 CLong, as it should.
1547 -}
1548
1549 {- *********************************************************************
1550 * *
1551 tcInferId
1552 * *
1553 ********************************************************************* -}
1554
1555 tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)
1556 tcCheckId name res_ty
1557 = do { (expr, actual_res_ty) <- tcInferId name
1558 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
1559 ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
1560 tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty }
1561
1562 tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId)
1563 tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty
1564 = do { (expr, actual_res_ty) <- tcInferRecSelId f
1565 ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
1566 tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty }
1567 tcCheckRecSelId (Ambiguous lbl _) res_ty
1568 = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
1569 Nothing -> ambiguousSelector lbl
1570 Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
1571 ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
1572
1573 ------------------------
1574 tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
1575 tcInferRecSelId (Unambiguous (L _ lbl) sel)
1576 = do { (expr', ty) <- tc_infer_id lbl sel
1577 ; return (expr', ty) }
1578 tcInferRecSelId (Ambiguous lbl _)
1579 = ambiguousSelector lbl
1580
1581 ------------------------
1582 tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType)
1583 -- Look up an occurrence of an Id
1584 tcInferId id_name
1585 | id_name `hasKey` tagToEnumKey
1586 = failWithTc (text "tagToEnum# must appear applied to one argument")
1587 -- tcApp catches the case (tagToEnum# arg)
1588
1589 | id_name `hasKey` assertIdKey
1590 = do { dflags <- getDynFlags
1591 ; if gopt Opt_IgnoreAsserts dflags
1592 then tc_infer_id (nameRdrName id_name) id_name
1593 else tc_infer_assert id_name }
1594
1595 | otherwise
1596 = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name
1597 ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
1598 ; return (expr, ty) }
1599
1600 tc_infer_assert :: Name -> TcM (HsExpr TcId, TcSigmaType)
1601 -- Deal with an occurrence of 'assert'
1602 -- See Note [Adding the implicit parameter to 'assert']
1603 tc_infer_assert assert_name
1604 = do { assert_error_id <- tcLookupId assertErrorName
1605 ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
1606 (idType assert_error_id)
1607 ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho)
1608 }
1609
1610 tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType)
1611 tc_infer_id lbl id_name
1612 = do { thing <- tcLookup id_name
1613 ; case thing of
1614 ATcId { tct_id = id }
1615 -> do { check_naughty id -- Note [Local record selectors]
1616 ; checkThLocalId id
1617 ; return_id id }
1618
1619 AGlobal (AnId id)
1620 -> do { check_naughty id
1621 ; return_id id }
1622 -- A global cannot possibly be ill-staged
1623 -- nor does it need the 'lifting' treatment
1624 -- hence no checkTh stuff here
1625
1626 AGlobal (AConLike cl) -> case cl of
1627 RealDataCon con -> return_data_con con
1628 PatSynCon ps -> tcPatSynBuilderOcc ps
1629
1630 _ -> failWithTc $
1631 ppr thing <+> text "used where a value identifier was expected" }
1632 where
1633 return_id id = return (HsVar (noLoc id), idType id)
1634
1635 return_data_con con
1636 -- For data constructors, must perform the stupid-theta check
1637 | null stupid_theta
1638 = return_id con_wrapper_id
1639
1640 | otherwise
1641 -- See Note [Instantiating stupid theta]
1642 = do { let (tvs, theta, rho) = tcSplitSigmaTy (idType con_wrapper_id)
1643 ; (subst, tvs') <- newMetaTyVars tvs
1644 ; let tys' = mkTyVarTys tvs'
1645 theta' = substTheta subst theta
1646 rho' = substTy subst rho
1647 ; wrap <- instCall (OccurrenceOf id_name) tys' theta'
1648 ; addDataConStupidTheta con tys'
1649 ; return (mkHsWrap wrap (HsVar (noLoc con_wrapper_id)), rho') }
1650
1651 where
1652 con_wrapper_id = dataConWrapId con
1653 stupid_theta = dataConStupidTheta con
1654
1655 check_naughty id
1656 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
1657 | otherwise = return ()
1658
1659
1660 tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr TcId)
1661 -- Typechedk an occurrence of an unbound Id
1662 --
1663 -- Some of these started life as a true hole "_". Others might simply
1664 -- be variables that accidentally have no binding site
1665 --
1666 -- We turn all of them into HsVar, since HsUnboundVar can't contain an
1667 -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
1668 -- not unbound any more!
1669 tcUnboundId unbound res_ty
1670 = do { ty <- newFlexiTyVarTy liftedTypeKind
1671 ; let occ = unboundVarOcc unbound
1672 ; name <- newSysName occ
1673 ; let ev = mkLocalId name ty
1674 ; loc <- getCtLocM HoleOrigin Nothing
1675 ; let can = CHoleCan { cc_ev = CtWanted { ctev_pred = ty
1676 , ctev_dest = EvVarDest ev
1677 , ctev_loc = loc}
1678 , cc_hole = ExprHole unbound }
1679 ; emitInsoluble can
1680 ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty }
1681
1682
1683 {-
1684 Note [Adding the implicit parameter to 'assert']
1685 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1686 The typechecker transforms (assert e1 e2) to (assertError e1 e2).
1687 This isn't really the Right Thing because there's no way to "undo"
1688 if you want to see the original source code in the typechecker
1689 output. We'll have fix this in due course, when we care more about
1690 being able to reconstruct the exact original program.
1691
1692 Note [tagToEnum#]
1693 ~~~~~~~~~~~~~~~~~
1694 Nasty check to ensure that tagToEnum# is applied to a type that is an
1695 enumeration TyCon. Unification may refine the type later, but this
1696 check won't see that, alas. It's crude, because it relies on our
1697 knowing *now* that the type is ok, which in turn relies on the
1698 eager-unification part of the type checker pushing enough information
1699 here. In theory the Right Thing to do is to have a new form of
1700 constraint but I definitely cannot face that! And it works ok as-is.
1701
1702 Here's are two cases that should fail
1703 f :: forall a. a
1704 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1705
1706 g :: Int
1707 g = tagToEnum# 0 -- Int is not an enumeration
1708
1709 When data type families are involved it's a bit more complicated.
1710 data family F a
1711 data instance F [Int] = A | B | C
1712 Then we want to generate something like
1713 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1714 Usually that coercion is hidden inside the wrappers for
1715 constructors of F [Int] but here we have to do it explicitly.
1716
1717 It's all grotesquely complicated.
1718
1719 Note [Instantiating stupid theta]
1720 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1721 Normally, when we infer the type of an Id, we don't instantiate,
1722 because we wish to allow for visible type application later on.
1723 But if a datacon has a stupid theta, we're a bit stuck. We need
1724 to emit the stupid theta constraints with instantiated types. It's
1725 difficult to defer this to the lazy instantiation, because a stupid
1726 theta has no spot to put it in a type. So we just instantiate eagerly
1727 in this case. Thus, users cannot use visible type application with
1728 a data constructor sporting a stupid theta. I won't feel so bad for
1729 the users that complain.
1730
1731 -}
1732
1733 tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]
1734 -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
1735 -- (seq e1 e2) :: res_ty
1736 -- We need a special typing rule because res_ty can be unboxed
1737 -- See Note [Typing rule for seq]
1738 tcSeq loc fun_name args res_ty
1739 = do { fun <- tcLookupId fun_name
1740 ; (arg1_ty, args1) <- case args of
1741 (Right hs_ty_arg1 : args1)
1742 -> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind
1743 ; return (ty_arg1, args1) }
1744
1745 _ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind
1746 ; return (arg_ty1, args) }
1747
1748 ; (arg1, arg2, arg2_exp_ty) <- case args1 of
1749 [Right hs_ty_arg2, Left term_arg1, Left term_arg2]
1750 -> do { rr_ty <- newFlexiTyVarTy runtimeRepTy
1751 ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE rr_ty)
1752 -- see Note [Typing rule for seq]
1753 ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty
1754 ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
1755 [Left term_arg1, Left term_arg2]
1756 -> return (term_arg1, term_arg2, res_ty)
1757 _ -> too_many_args "seq" args
1758
1759 ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
1760 ; arg2' <- tcMonoExpr arg2 arg2_exp_ty
1761 ; res_ty <- readExpType res_ty -- by now, it's surely filled in
1762 ; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun)))
1763 ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
1764 ; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
1765
1766 tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
1767 -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
1768 -- tagToEnum# :: forall a. Int# -> a
1769 -- See Note [tagToEnum#] Urgh!
1770 tcTagToEnum loc fun_name args res_ty
1771 = do { fun <- tcLookupId fun_name
1772
1773 ; arg <- case args of
1774 [Right hs_ty_arg, Left term_arg]
1775 -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
1776 ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg res_ty
1777 -- other than influencing res_ty, we just
1778 -- don't care about a type arg passed in.
1779 -- So drop the evidence.
1780 ; return term_arg }
1781 [Left term_arg] -> do { _ <- expTypeToType res_ty
1782 ; return term_arg }
1783 _ -> too_many_args "tagToEnum#" args
1784
1785 ; res_ty <- readExpType res_ty
1786 ; ty' <- zonkTcType res_ty
1787
1788 -- Check that the type is algebraic
1789 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1790 Just (tc, tc_args) = mb_tc_app
1791 ; checkTc (isJust mb_tc_app)
1792 (mk_error ty' doc1)
1793
1794 -- Look through any type family
1795 ; fam_envs <- tcGetFamInstEnvs
1796 ; let (rep_tc, rep_args, coi)
1797 = tcLookupDataFamInst fam_envs tc tc_args
1798 -- coi :: tc tc_args ~R rep_tc rep_args
1799
1800 ; checkTc (isEnumerationTyCon rep_tc)
1801 (mk_error ty' doc2)
1802
1803 ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
1804 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
1805 rep_ty = mkTyConApp rep_tc rep_args
1806
1807 ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
1808 -- coi is a Representational coercion
1809 where
1810 doc1 = vcat [ text "Specify the type by giving a type signature"
1811 , text "e.g. (tagToEnum# x) :: Bool" ]
1812 doc2 = text "Result type must be an enumeration type"
1813
1814 mk_error :: TcType -> SDoc -> SDoc
1815 mk_error ty what
1816 = hang (text "Bad call to tagToEnum#"
1817 <+> text "at type" <+> ppr ty)
1818 2 what
1819
1820 too_many_args :: String -> [LHsExprArgIn] -> TcM a
1821 too_many_args fun args
1822 = failWith $
1823 hang (text "Too many type arguments to" <+> text fun <> colon)
1824 2 (sep (map pp args))
1825 where
1826 pp (Left e) = pprParendLExpr e
1827 pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
1828
1829
1830 {-
1831 ************************************************************************
1832 * *
1833 Template Haskell checks
1834 * *
1835 ************************************************************************
1836 -}
1837
1838 checkThLocalId :: Id -> TcM ()
1839 checkThLocalId id
1840 = do { mb_local_use <- getStageAndBindLevel (idName id)
1841 ; case mb_local_use of
1842 Just (top_lvl, bind_lvl, use_stage)
1843 | thLevel use_stage > bind_lvl
1844 , isNotTopLevel top_lvl
1845 -> checkCrossStageLifting id use_stage
1846 _ -> return () -- Not a locally-bound thing, or
1847 -- no cross-stage link
1848 }
1849
1850 --------------------------------------
1851 checkCrossStageLifting :: Id -> ThStage -> TcM ()
1852 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
1853 -- we must check whether there's a cross-stage lift to do
1854 -- Examples \x -> [|| x ||]
1855 -- [|| map ||]
1856 -- There is no error-checking to do, because the renamer did that
1857 --
1858 -- This is similar to checkCrossStageLifting in RnSplice, but
1859 -- this code is applied to *typed* brackets.
1860
1861 checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
1862 = -- Nested identifiers, such as 'x' in
1863 -- E.g. \x -> [|| h x ||]
1864 -- We must behave as if the reference to x was
1865 -- h $(lift x)
1866 -- We use 'x' itself as the splice proxy, used by
1867 -- the desugarer to stitch it all back together.
1868 -- If 'x' occurs many times we may get many identical
1869 -- bindings of the same splice proxy, but that doesn't
1870 -- matter, although it's a mite untidy.
1871 do { let id_ty = idType id
1872 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1873 -- If x is polymorphic, its occurrence sites might
1874 -- have different instantiations, so we can't use plain
1875 -- 'x' as the splice proxy name. I don't know how to
1876 -- solve this, and it's probably unimportant, so I'm
1877 -- just going to flag an error for now
1878
1879 ; lift <- if isStringTy id_ty then
1880 do { sid <- tcLookupId THNames.liftStringName
1881 -- See Note [Lifting strings]
1882 ; return (HsVar (noLoc sid)) }
1883 else
1884 setConstraintVar lie_var $
1885 -- Put the 'lift' constraint into the right LIE
1886 newMethodFromName (OccurrenceOf (idName id))
1887 THNames.liftName id_ty
1888
1889 -- Update the pending splices
1890 ; ps <- readMutVar ps_var
1891 ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
1892 ; writeMutVar ps_var (pending_splice : ps)
1893
1894 ; return () }
1895
1896 checkCrossStageLifting _ _ = return ()
1897
1898 polySpliceErr :: Id -> SDoc
1899 polySpliceErr id
1900 = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)
1901
1902 {-
1903 Note [Lifting strings]
1904 ~~~~~~~~~~~~~~~~~~~~~~
1905 If we see $(... [| s |] ...) where s::String, we don't want to
1906 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1907 So this conditional short-circuits the lifting mechanism to generate
1908 (liftString "xy") in that case. I didn't want to use overlapping instances
1909 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1910 errors in a polymorphic situation.
1911
1912 If this check fails (which isn't impossible) we get another chance; see
1913 Note [Converting strings] in Convert.hs
1914
1915 Local record selectors
1916 ~~~~~~~~~~~~~~~~~~~~~~
1917 Record selectors for TyCons in this module are ordinary local bindings,
1918 which show up as ATcIds rather than AGlobals. So we need to check for
1919 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1920
1921
1922 ************************************************************************
1923 * *
1924 \subsection{Record bindings}
1925 * *
1926 ************************************************************************
1927 -}
1928
1929 getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
1930 -- These tyvars must not change across the updates
1931 getFixedTyVars upd_fld_occs univ_tvs cons
1932 = mkVarSet [tv1 | con <- cons
1933 , let (u_tvs, _, eqspec, prov_theta
1934 , req_theta, arg_tys, _)
1935 = conLikeFullSig con
1936 theta = eqSpecPreds eqspec
1937 ++ prov_theta
1938 ++ req_theta
1939 flds = conLikeFieldLabels con
1940 fixed_tvs = exactTyCoVarsOfTypes fixed_tys
1941 -- fixed_tys: See Note [Type of a record update]
1942 `unionVarSet` tyCoVarsOfTypes theta
1943 -- Universally-quantified tyvars that
1944 -- appear in any of the *implicit*
1945 -- arguments to the constructor are fixed
1946 -- See Note [Implict type sharing]
1947
1948 fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
1949 , not (flLabel fl `elem` upd_fld_occs)]
1950 , (tv1,tv) <- univ_tvs `zip` u_tvs
1951 , tv `elemVarSet` fixed_tvs ]
1952
1953 {-
1954 Note [Disambiguating record fields]
1955 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1956 When the -XDuplicateRecordFields extension is used, and the renamer
1957 encounters a record selector or update that it cannot immediately
1958 disambiguate (because it involves fields that belong to multiple
1959 datatypes), it will defer resolution of the ambiguity to the
1960 typechecker. In this case, the `Ambiguous` constructor of
1961 `AmbiguousFieldOcc` is used.
1962
1963 Consider the following definitions:
1964
1965 data S = MkS { foo :: Int }
1966 data T = MkT { foo :: Int, bar :: Int }
1967 data U = MkU { bar :: Int, baz :: Int }
1968
1969 When the renamer sees `foo` as a selector or an update, it will not
1970 know which parent datatype is in use.
1971
1972 For selectors, there are two possible ways to disambiguate:
1973
1974 1. Check if the pushed-in type is a function whose domain is a
1975 datatype, for example:
1976
1977 f s = (foo :: S -> Int) s
1978
1979 g :: T -> Int
1980 g = foo
1981
1982 This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
1983
1984 2. Check if the selector is applied to an argument that has a type
1985 signature, for example:
1986
1987 h = foo (s :: S)
1988
1989 This is checked by `tcApp`.
1990
1991
1992 Updates are slightly more complex. The `disambiguateRecordBinds`
1993 function tries to determine the parent datatype in three ways:
1994
1995 1. Check for types that have all the fields being updated. For example:
1996
1997 f x = x { foo = 3, bar = 2 }
1998
1999 Here `f` must be updating `T` because neither `S` nor `U` have
2000 both fields. This may also discover that no possible type exists.
2001 For example the following will be rejected:
2002
2003 f' x = x { foo = 3, baz = 3 }
2004
2005 2. Use the type being pushed in, if it is already a TyConApp. The
2006 following are valid updates to `T`:
2007
2008 g :: T -> T
2009 g x = x { foo = 3 }
2010
2011 g' x = x { foo = 3 } :: T
2012
2013 3. Use the type signature of the record expression, if it exists and
2014 is a TyConApp. Thus this is valid update to `T`:
2015
2016 h x = (x :: T) { foo = 3 }
2017
2018
2019 Note that we do not look up the types of variables being updated, and
2020 no constraint-solving is performed, so for example the following will
2021 be rejected as ambiguous:
2022
2023 let bad (s :: S) = foo s
2024
2025 let r :: T
2026 r = blah
2027 in r { foo = 3 }
2028
2029 \r. (r { foo = 3 }, r :: T )
2030
2031 We could add further tests, of a more heuristic nature. For example,
2032 rather than looking for an explicit signature, we could try to infer
2033 the type of the argument to a selector or the record expression being
2034 updated, in case we are lucky enough to get a TyConApp straight
2035 away. However, it might be hard for programmers to predict whether a
2036 particular update is sufficiently obvious for the signature to be
2037 omitted. Moreover, this might change the behaviour of typechecker in
2038 non-obvious ways.
2039
2040 See also Note [HsRecField and HsRecUpdField] in HsPat.
2041 -}
2042
2043 -- Given a RdrName that refers to multiple record fields, and the type
2044 -- of its argument, try to determine the name of the selector that is
2045 -- meant.
2046 disambiguateSelector :: Located RdrName -> Type -> TcM Name
2047 disambiguateSelector lr@(L _ rdr) parent_type
2048 = do { fam_inst_envs <- tcGetFamInstEnvs
2049 ; case tyConOf fam_inst_envs parent_type of
2050 Nothing -> ambiguousSelector lr
2051 Just p ->
2052 do { xs <- lookupParents rdr
2053 ; let parent = RecSelData p
2054 ; case lookup parent xs of
2055 Just gre -> do { addUsedGRE True gre
2056 ; return (gre_name gre) }
2057 Nothing -> failWithTc (fieldNotInType parent rdr) } }
2058
2059 -- This field name really is ambiguous, so add a suitable "ambiguous
2060 -- occurrence" error, then give up.
2061 ambiguousSelector :: Located RdrName -> TcM a
2062 ambiguousSelector (L _ rdr)
2063 = do { env <- getGlobalRdrEnv
2064 ; let gres = lookupGRE_RdrName rdr env
2065 ; setErrCtxt [] $ addNameClashErrRn rdr gres
2066 ; failM }
2067
2068 -- Disambiguate the fields in a record update.
2069 -- See Note [Disambiguating record fields]
2070 disambiguateRecordBinds :: LHsExpr Name -> TcRhoType
2071 -> [LHsRecUpdField Name] -> ExpRhoType
2072 -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
2073 disambiguateRecordBinds record_expr record_rho rbnds res_ty
2074 -- Are all the fields unambiguous?
2075 = case mapM isUnambiguous rbnds of
2076 -- If so, just skip to looking up the Ids
2077 -- Always the case if DuplicateRecordFields is off
2078 Just rbnds' -> mapM lookupSelector rbnds'
2079 Nothing -> -- If not, try to identify a single parent
2080 do { fam_inst_envs <- tcGetFamInstEnvs
2081 -- Look up the possible parents for each field
2082 ; rbnds_with_parents <- getUpdFieldsParents
2083 ; let possible_parents = map (map fst . snd) rbnds_with_parents
2084 -- Identify a single parent
2085 ; p <- identifyParent fam_inst_envs possible_parents
2086 -- Pick the right selector with that parent for each field
2087 ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
2088 where
2089 -- Extract the selector name of a field update if it is unambiguous
2090 isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)
2091 isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
2092 Unambiguous _ sel_name -> Just (x, sel_name)
2093 Ambiguous{} -> Nothing
2094
2095 -- Look up the possible parents and selector GREs for each field
2096 getUpdFieldsParents :: TcM [(LHsRecUpdField Name
2097 , [(RecSelParent, GlobalRdrElt)])]
2098 getUpdFieldsParents
2099 = fmap (zip rbnds) $ mapM
2100 (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
2101 rbnds
2102
2103 -- Given a the lists of possible parents for each field,
2104 -- identify a single parent
2105 identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
2106 identifyParent fam_inst_envs possible_parents
2107 = case foldr1 intersect possible_parents of
2108 -- No parents for all fields: record update is ill-typed
2109 [] -> failWithTc (noPossibleParents rbnds)
2110
2111 -- Exactly one datatype with all the fields: use that
2112 [p] -> return p
2113
2114 -- Multiple possible parents: try harder to disambiguate
2115 -- Can we get a parent TyCon from the pushed-in type?
2116 _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)
2117
2118 -- Does the expression being updated have a type signature?
2119 -- If so, try to extract a parent TyCon from it
2120 | Just {} <- obviousSig (unLoc record_expr)
2121 , Just tc <- tyConOf fam_inst_envs record_rho
2122 -> return (RecSelData tc)
2123
2124 -- Nothing else we can try...
2125 _ -> failWithTc badOverloadedUpdate
2126
2127 -- Make a field unambiguous by choosing the given parent.
2128 -- Emits an error if the field cannot have that parent,
2129 -- e.g. if the user writes
2130 -- r { x = e } :: T
2131 -- where T does not have field x.
2132 pickParent :: RecSelParent
2133 -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
2134 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
2135 pickParent p (upd, xs)
2136 = case lookup p xs of
2137 -- Phew! The parent is valid for this field.
2138 -- Previously ambiguous fields must be marked as
2139 -- used now that we know which one is meant, but
2140 -- unambiguous ones shouldn't be recorded again
2141 -- (giving duplicate deprecation warnings).
2142 Just gre -> do { unless (null (tail xs)) $ do
2143 let L loc _ = hsRecFieldLbl (unLoc upd)
2144 setSrcSpan loc $ addUsedGRE True gre
2145 ; lookupSelector (upd, gre_name gre) }
2146 -- The field doesn't belong to this parent, so report
2147 -- an error but keep going through all the fields
2148 Nothing -> do { addErrTc (fieldNotInType p
2149 (unLoc (hsRecUpdFieldRdr (unLoc upd))))
2150 ; lookupSelector (upd, gre_name (snd (head xs))) }
2151
2152 -- Given a (field update, selector name) pair, look up the
2153 -- selector to give a field update with an unambiguous Id
2154 lookupSelector :: (LHsRecUpdField Name, Name)
2155 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
2156 lookupSelector (L l upd, n)
2157 = do { i <- tcLookupId n
2158 ; let L loc af = hsRecFieldLbl upd
2159 lbl = rdrNameAmbiguousFieldOcc af
2160 ; return $ L l upd { hsRecFieldLbl
2161 = L loc (Unambiguous (L loc lbl) i) } }
2162
2163
2164 -- Extract the outermost TyCon of a type, if there is one; for
2165 -- data families this is the representation tycon (because that's
2166 -- where the fields live).
2167 tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
2168 tyConOf fam_inst_envs ty0
2169 = case tcSplitTyConApp_maybe ty of
2170 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
2171 Nothing -> Nothing
2172 where
2173 (_, _, ty) = tcSplitSigmaTy ty0
2174
2175 -- Variant of tyConOf that works for ExpTypes
2176 tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
2177 tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
2178
2179 -- For an ambiguous record field, find all the candidate record
2180 -- selectors (as GlobalRdrElts) and their parents.
2181 lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
2182 lookupParents rdr
2183 = do { env <- getGlobalRdrEnv
2184 ; let gres = lookupGRE_RdrName rdr env
2185 ; mapM lookupParent gres }
2186 where
2187 lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
2188 lookupParent gre = do { id <- tcLookupId (gre_name gre)
2189 ; if isRecordSelector id
2190 then return (recordSelectorTyCon id, gre)
2191 else failWithTc (notSelector (gre_name gre)) }
2192
2193 -- A type signature on the argument of an ambiguous record selector or
2194 -- the record expression in an update must be "obvious", i.e. the
2195 -- outermost constructor ignoring parentheses.
2196 obviousSig :: HsExpr Name -> Maybe (LHsSigWcType Name)
2197 obviousSig (ExprWithTySig _ ty) = Just ty
2198 obviousSig (HsPar p) = obviousSig (unLoc p)
2199 obviousSig _ = Nothing
2200
2201
2202 {-
2203 Game plan for record bindings
2204 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2205 1. Find the TyCon for the bindings, from the first field label.
2206
2207 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
2208
2209 For each binding field = value
2210
2211 3. Instantiate the field type (from the field label) using the type
2212 envt from step 2.
2213
2214 4 Type check the value using tcArg, passing the field type as
2215 the expected argument type.
2216
2217 This extends OK when the field types are universally quantified.
2218 -}
2219
2220 tcRecordBinds
2221 :: ConLike
2222 -> [TcType] -- Expected type for each field
2223 -> HsRecordBinds Name
2224 -> TcM (HsRecordBinds TcId)
2225
2226 tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
2227 = do { mb_binds <- mapM do_bind rbinds
2228 ; return (HsRecFields (catMaybes mb_binds) dd) }
2229 where
2230 fields = map flLabel $ conLikeFieldLabels con_like
2231 flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
2232
2233 do_bind :: LHsRecField Name (LHsExpr Name)
2234 -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId)))
2235 do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
2236 , hsRecFieldArg = rhs }))
2237
2238 = do { mb <- tcRecordField con_like flds_w_tys f rhs
2239 ; case mb of
2240 Nothing -> return Nothing
2241 Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
2242 , hsRecFieldArg = rhs' }))) }
2243
2244 tcRecordUpd
2245 :: ConLike
2246 -> [TcType] -- Expected type for each field
2247 -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
2248 -> TcM [LHsRecUpdField TcId]
2249
2250 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
2251 where
2252 flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys
2253
2254 do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId))
2255 do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
2256 , hsRecFieldArg = rhs }))
2257 = do { let lbl = rdrNameAmbiguousFieldOcc af
2258 sel_id = selectorAmbiguousFieldOcc af
2259 f = L loc (FieldOcc (L loc lbl) (idName sel_id))
2260 ; mb <- tcRecordField con_like flds_w_tys f rhs
2261 ; case mb of
2262 Nothing -> return Nothing
2263 Just (f', rhs') ->
2264 return (Just
2265 (L l (fld { hsRecFieldLbl
2266 = L loc (Unambiguous (L loc lbl)
2267 (selectorFieldOcc (unLoc f')))
2268 , hsRecFieldArg = rhs' }))) }
2269
2270 tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name
2271 -> TcM (Maybe (LFieldOcc Id, LHsExpr Id))
2272 tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
2273 | Just field_ty <- assocMaybe flds_w_tys field_lbl
2274 = addErrCtxt (fieldCtxt field_lbl) $
2275 do { rhs' <- tcPolyExprNC rhs field_ty
2276 ; let field_id = mkUserLocal (nameOccName sel_name)
2277 (nameUnique sel_name)
2278 field_ty loc
2279 -- Yuk: the field_id has the *unique* of the selector Id
2280 -- (so we can find it easily)
2281 -- but is a LocalId with the appropriate type of the RHS
2282 -- (so the desugarer knows the type of local binder to make)
2283 ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
2284 | otherwise
2285 = do { addErrTc (badFieldCon con_like field_lbl)
2286 ; return Nothing }
2287 where
2288 field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
2289
2290
2291 checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM ()
2292 checkMissingFields con_like rbinds
2293 | null field_labels -- Not declared as a record;
2294 -- But C{} is still valid if no strict fields
2295 = if any isBanged field_strs then
2296 -- Illegal if any arg is strict
2297 addErrTc (missingStrictFields con_like [])
2298 else
2299 return ()
2300
2301 | otherwise = do -- A record
2302 unless (null missing_s_fields)
2303 (addErrTc (missingStrictFields con_like missing_s_fields))
2304
2305 warn <- woptM Opt_WarnMissingFields
2306 unless (not (warn && notNull missing_ns_fields))
2307 (warnTc (Reason Opt_WarnMissingFields) True
2308 (missingFields con_like missing_ns_fields))
2309
2310 where
2311 missing_s_fields
2312 = [ flLabel fl | (fl, str) <- field_info,
2313 isBanged str,
2314 not (fl `elemField` field_names_used)
2315 ]
2316 missing_ns_fields
2317 = [ flLabel fl | (fl, str) <- field_info,
2318 not (isBanged str),
2319 not (fl `elemField` field_names_used)
2320 ]
2321
2322 field_names_used = hsRecFields rbinds
2323 field_labels = conLikeFieldLabels con_like
2324
2325 field_info = zipEqual "missingFields"
2326 field_labels
2327 field_strs
2328
2329 field_strs = conLikeImplBangs con_like
2330
2331 fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
2332
2333 {-
2334 ************************************************************************
2335 * *
2336 \subsection{Errors and contexts}
2337 * *
2338 ************************************************************************
2339
2340 Boring and alphabetical:
2341 -}
2342
2343 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
2344 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
2345
2346 exprCtxt :: LHsExpr Name -> SDoc
2347 exprCtxt expr
2348 = hang (text "In the expression:") 2 (ppr expr)
2349
2350 fieldCtxt :: FieldLabelString -> SDoc
2351 fieldCtxt field_name
2352 = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
2353
2354 addFunResCtxt :: Bool -- There is at least one argument
2355 -> HsExpr Name -> TcType -> ExpRhoType
2356 -> TcM a -> TcM a
2357 -- When we have a mis-match in the return type of a function
2358 -- try to give a helpful message about too many/few arguments
2359 --
2360 -- Used for naked variables too; but with has_args = False
2361 addFunResCtxt has_args fun fun_res_ty env_ty
2362 = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)
2363 -- NB: use a landmark error context, so that an empty context
2364 -- doesn't suppress some more useful context
2365 where
2366 mk_msg
2367 = do { mb_env_ty <- readExpType_maybe env_ty
2368 -- by the time the message is rendered, the ExpType
2369 -- will be filled in (except if we're debugging)
2370 ; fun_res' <- zonkTcType fun_res_ty
2371 ; env' <- case mb_env_ty of
2372 Just env_ty -> zonkTcType env_ty
2373 Nothing ->
2374 do { dumping <- doptM Opt_D_dump_tc_trace
2375 ; MASSERT( dumping )
2376 ; newFlexiTyVarTy liftedTypeKind }
2377 ; let (_, _, fun_tau) = tcSplitSigmaTy fun_res'
2378 (_, _, env_tau) = tcSplitSigmaTy env'
2379 (args_fun, res_fun) = tcSplitFunTys fun_tau
2380 (args_env, res_env) = tcSplitFunTys env_tau
2381 n_fun = length args_fun
2382 n_env = length args_env
2383 info | n_fun == n_env = Outputable.empty
2384 | n_fun > n_env
2385 , not_fun res_env
2386 = text "Probable cause:" <+> quotes (ppr fun)
2387 <+> text "is applied to too few arguments"
2388
2389 | has_args
2390 , not_fun res_fun
2391 = text "Possible cause:" <+> quotes (ppr fun)
2392 <+> text "is applied to too many arguments"
2393
2394 | otherwise
2395 = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args!
2396 ; return info }
2397 where
2398 not_fun ty -- ty is definitely not an arrow type,
2399 -- and cannot conceivably become one
2400 = case tcSplitTyConApp_maybe ty of
2401 Just (tc, _) -> isAlgTyCon tc
2402 Nothing -> False
2403
2404 badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
2405 badFieldTypes prs
2406 = hang (text "Record update for insufficiently polymorphic field"
2407 <> plural prs <> colon)
2408 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
2409
2410 badFieldsUpd
2411 :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon
2412 -> [ConLike] -- Data cons of the type which the first field name belongs to
2413 -> SDoc
2414 badFieldsUpd rbinds data_cons
2415 = hang (text "No constructor has all these fields:")
2416 2 (pprQuotedList conflictingFields)
2417 -- See Note [Finding the conflicting fields]
2418 where
2419 -- A (preferably small) set of fields such that no constructor contains
2420 -- all of them. See Note [Finding the conflicting fields]
2421 conflictingFields = case nonMembers of
2422 -- nonMember belongs to a different type.
2423 (nonMember, _) : _ -> [aMember, nonMember]
2424 [] -> let
2425 -- All of rbinds belong to one type. In this case, repeatedly add
2426 -- a field to the set until no constructor contains the set.
2427
2428 -- Each field, together with a list indicating which constructors
2429 -- have all the fields so far.
2430 growingSets :: [(FieldLabelString, [Bool])]
2431 growingSets = scanl1 combine membership
2432 combine (_, setMem) (field, fldMem)
2433 = (field, zipWith (&&) setMem fldMem)
2434 in
2435 -- Fields that don't change the membership status of the set
2436 -- are redundant and can be dropped.
2437 map (fst . head) $ groupBy ((==) `on` snd) growingSets
2438
2439 aMember = ASSERT( not (null members) ) fst (head members)
2440 (members, nonMembers) = partition (or . snd) membership
2441
2442 -- For each field, which constructors contain the field?
2443 membership :: [(FieldLabelString, [Bool])]
2444 membership = sortMembership $
2445 map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
2446 map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
2447
2448 fieldLabelSets :: [Set.Set FieldLabelString]
2449 fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
2450
2451 -- Sort in order of increasing number of True, so that a smaller
2452 -- conflicting set can be found.
2453 sortMembership =
2454 map snd .
2455 sortBy (compare `on` fst) .
2456 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
2457
2458 countTrue = length . filter id
2459
2460 {-
2461 Note [Finding the conflicting fields]
2462 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2463 Suppose we have
2464 data A = A {a0, a1 :: Int}
2465 | B {b0, b1 :: Int}
2466 and we see a record update
2467 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
2468 Then we'd like to find the smallest subset of fields that no
2469 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
2470 We don't really want to report that no constructor has all of
2471 {a0,a1,b0,b1}, because when there are hundreds of fields it's
2472 hard to see what was really wrong.
2473
2474 We may need more than two fields, though; eg
2475 data T = A { x,y :: Int, v::Int }
2476 | B { y,z :: Int, v::Int }
2477 | C { z,x :: Int, v::Int }
2478 with update
2479 r { x=e1, y=e2, z=e3 }, we
2480
2481 Finding the smallest subset is hard, so the code here makes
2482 a decent stab, no more. See Trac #7989.
2483 -}
2484
2485 naughtyRecordSel :: RdrName -> SDoc
2486 naughtyRecordSel sel_id
2487 = text "Cannot use record selector" <+> quotes (ppr sel_id) <+>
2488 text "as a function due to escaped type variables" $$
2489 text "Probable fix: use pattern-matching syntax instead"
2490
2491 notSelector :: Name -> SDoc
2492 notSelector field
2493 = hsep [quotes (ppr field), text "is not a record selector"]
2494
2495 mixedSelectors :: [Id] -> [Id] -> SDoc
2496 mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
2497 = ptext
2498 (sLit "Cannot use a mixture of pattern synonym and record selectors") $$
2499 text "Record selectors defined by"
2500 <+> quotes (ppr (tyConName rep_dc))
2501 <> text ":"
2502 <+> pprWithCommas ppr data_sels $$
2503 text "Pattern synonym selectors defined by"
2504 <+> quotes (ppr (patSynName rep_ps))
2505 <> text ":"
2506 <+> pprWithCommas ppr pat_syn_sels
2507 where
2508 RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
2509 RecSelData rep_dc = recordSelectorTyCon dc_rep_id
2510 mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"
2511
2512
2513 missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
2514 missingStrictFields con fields
2515 = header <> rest
2516 where
2517 rest | null fields = Outputable.empty -- Happens for non-record constructors
2518 -- with strict fields
2519 | otherwise = colon <+> pprWithCommas ppr fields
2520
2521 header = text "Constructor" <+> quotes (ppr con) <+>
2522 text "does not have the required strict field(s)"
2523
2524 missingFields :: ConLike -> [FieldLabelString] -> SDoc
2525 missingFields con fields
2526 = text "Fields of" <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
2527 <+> pprWithCommas ppr fields
2528
2529 -- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args))
2530
2531 noPossibleParents :: [LHsRecUpdField Name] -> SDoc
2532 noPossibleParents rbinds
2533 = hang (text "No type has all these fields:")
2534 2 (pprQuotedList fields)
2535 where
2536 fields = map (hsRecFieldLbl . unLoc) rbinds
2537
2538 badOverloadedUpdate :: SDoc
2539 badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"
2540
2541 fieldNotInType :: RecSelParent -> RdrName -> SDoc
2542 fieldNotInType p rdr
2543 = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr
2544
2545 {-
2546 ************************************************************************
2547 * *
2548 \subsection{Static Pointers}
2549 * *
2550 ************************************************************************
2551 -}
2552
2553 -- | A data type to describe why a variable is not closed.
2554 data NotClosedReason = NotLetBoundReason
2555 | NotTypeClosed VarSet
2556 | NotClosed Name NotClosedReason
2557
2558 -- | Checks if the given name is closed and emits an error if not.
2559 --
2560 -- See Note [Not-closed error messages].
2561 checkClosedInStaticForm :: Name -> TcM ()
2562 checkClosedInStaticForm name = do
2563 type_env <- getLclTypeEnv
2564 case checkClosed type_env name of
2565 Nothing -> return ()
2566 Just reason -> addErrTc $ explain name reason
2567 where
2568 -- See Note [Checking closedness].
2569 checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
2570 checkClosed type_env n = checkLoop type_env (unitNameSet n) n
2571
2572 checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
2573 checkLoop type_env visited n = do
2574 -- The @visited@ set is an accumulating parameter that contains the set of
2575 -- visited nodes, so we avoid repeating cycles in the traversal.
2576 case lookupNameEnv type_env n of
2577 Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
2578 ClosedLet -> Nothing
2579 NotLetBound -> Just NotLetBoundReason
2580 NonClosedLet fvs type_closed -> listToMaybe $
2581 -- Look for a non-closed variable in fvs
2582 [ NotClosed n' reason
2583 | n' <- nameSetElemsStable fvs
2584 , not (elemNameSet n' visited)
2585 , Just reason <- [checkLoop type_env (extendNameSet visited n') n']
2586 ] ++
2587 if type_closed then
2588 []
2589 else
2590 -- We consider non-let-bound variables easier to figure out than
2591 -- non-closed types, so we report non-closed types to the user
2592 -- only if we cannot spot the former.
2593 [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
2594 -- The binding is closed.
2595 _ -> Nothing
2596
2597 -- Converts a reason into a human-readable sentence.
2598 --
2599 -- @explain name reason@ starts with
2600 --
2601 -- "<name> is used in a static form but it is not closed because it"
2602 --
2603 -- and then follows a list of causes. For each id in the path, the text
2604 --
2605 -- "uses <id> which"
2606 --
2607 -- is appended, yielding something like
2608 --
2609 -- "uses <id> which uses <id1> which uses <id2> which"
2610 --
2611 -- until the end of the path is reached, which is reported as either
2612 --
2613 -- "is not let-bound"
2614 --
2615 -- when the final node is not let-bound, or
2616 --
2617 -- "has a non-closed type because it contains the type variables:
2618 -- v1, v2, v3"
2619 --
2620 -- when the final node has a non-closed type.
2621 --
2622 explain :: Name -> NotClosedReason -> SDoc
2623 explain name reason =
2624 quotes (ppr name) <+> text "is used in a static form but it is not closed"
2625 <+> text "because it"
2626 $$
2627 sep (causes reason)
2628
2629 causes :: NotClosedReason -> [SDoc]
2630 causes NotLetBoundReason = [text "is not let-bound."]
2631 causes (NotTypeClosed vs) =
2632 [ text "has a non-closed type because it contains the"
2633 , text "type variables:" <+>
2634 pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))
2635 ]
2636 causes (NotClosed n reason) =
2637 let msg = text "uses" <+> quotes (ppr n) <+> text "which"
2638 in case reason of
2639 NotClosed _ _ -> msg : causes reason
2640 _ -> let (xs0, xs1) = splitAt 1 $ causes reason
2641 in fmap (msg <+>) xs0 ++ xs1
2642
2643 -- Note [Not-closed error messages]
2644 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2645 --
2646 -- When variables in a static form are not closed, we go through the trouble
2647 -- of explaining why they aren't.
2648 --
2649 -- Thus, the following program
2650 --
2651 -- > {-# LANGUAGE StaticPointers #-}
2652 -- > module M where
2653 -- >
2654 -- > f x = static g
2655 -- > where
2656 -- > g = h
2657 -- > h = x
2658 --
2659 -- produces the error
2660 --
2661 -- 'g' is used in a static form but it is not closed because it
2662 -- uses 'h' which uses 'x' which is not let-bound.
2663 --
2664 -- And a program like
2665 --
2666 -- > {-# LANGUAGE StaticPointers #-}
2667 -- > module M where
2668 -- >
2669 -- > import Data.Typeable
2670 -- > import GHC.StaticPtr
2671 -- >
2672 -- > f :: Typeable a => a -> StaticPtr TypeRep
2673 -- > f x = const (static (g undefined)) (h x)
2674 -- > where
2675 -- > g = h
2676 -- > h = typeOf
2677 --
2678 -- produces the error
2679 --
2680 -- 'g' is used in a static form but it is not closed because it
2681 -- uses 'h' which has a non-closed type because it contains the
2682 -- type variables: 'a'
2683 --
2684
2685 -- Note [Checking closedness]
2686 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
2687 --
2688 -- @checkClosed@ checks if a binding is closed and returns a reason if it is
2689 -- not.
2690 --
2691 -- The bindings define a graph where the nodes are ids, and there is an edge
2692 -- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
2693 -- variables.
2694 --
2695 -- When @n@ is not closed, it has to exist in the graph some node reachable
2696 -- from @n@ that it is not a let-bound variable or that it has a non-closed
2697 -- type. Thus, the "reason" is a path from @n@ to this offending node.
2698 --
2699 -- When @n@ is not closed, we traverse the graph reachable from @n@ to build
2700 -- the reason.
2701 --