Make seq-of-cast rule generate a case
[ghc.git] / compiler / typecheck / TcExpr.hs
1 {-
2 c%
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 #-}
10
11 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
12 tcInferRho, tcInferRhoNC,
13 tcSyntaxOp, tcCheckId,
14 addExprErrCtxt) where
15
16 #include "HsVersions.h"
17
18 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
19 import THNames( liftStringName, liftName )
20
21 import HsSyn
22 import TcHsSyn
23 import TcRnMonad
24 import TcUnify
25 import BasicTypes
26 import Inst
27 import TcBinds
28 import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
29 import TcEnv
30 import TcArrows
31 import TcMatches
32 import TcHsType
33 import TcPatSyn( tcPatSynBuilderOcc )
34 import TcPat
35 import TcMType
36 import TcType
37 import DsMonad
38 import Id
39 import ConLike
40 import DataCon
41 import Name
42 import TyCon
43 import Type
44 import TcEvidence
45 import Var
46 import VarSet
47 import VarEnv
48 import TysWiredIn
49 import TysPrim( intPrimTy, addrPrimTy )
50 import PrimOp( tagToEnumKey )
51 import PrelNames
52 import DynFlags
53 import SrcLoc
54 import Util
55 import ListSetOps
56 import Maybes
57 import ErrUtils
58 import Outputable
59 import FastString
60 import Control.Monad
61 import Class(classTyCon)
62 import Data.Function
63 import Data.List
64 import qualified Data.Set as Set
65
66 {-
67 ************************************************************************
68 * *
69 \subsection{Main wrappers}
70 * *
71 ************************************************************************
72 -}
73
74 tcPolyExpr, tcPolyExprNC
75 :: LHsExpr Name -- Expression to type check
76 -> TcSigmaType -- Expected type (could be a polytype)
77 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
78
79 -- tcPolyExpr is a convenient place (frequent but not too frequent)
80 -- place to add context information.
81 -- The NC version does not do so, usually because the caller wants
82 -- to do so himself.
83
84 tcPolyExpr expr res_ty
85 = addExprErrCtxt expr $
86 do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
87
88 tcPolyExprNC expr res_ty
89 = do { traceTc "tcPolyExprNC" (ppr res_ty)
90 ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
91 tcMonoExprNC expr rho
92 ; return (mkLHsWrap gen_fn expr') }
93
94 ---------------
95 tcMonoExpr, tcMonoExprNC
96 :: LHsExpr Name -- Expression to type check
97 -> TcRhoType -- Expected type (could be a type variable)
98 -- Definitely no foralls at the top
99 -> TcM (LHsExpr TcId)
100
101 tcMonoExpr expr res_ty
102 = addErrCtxt (exprCtxt expr) $
103 tcMonoExprNC expr res_ty
104
105 tcMonoExprNC (L loc expr) res_ty
106 = ASSERT( not (isSigmaTy res_ty) )
107 setSrcSpan loc $
108 do { expr' <- tcExpr expr res_ty
109 ; return (L loc expr') }
110
111 ---------------
112 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
113 -- Infer a *rho*-type. This is, in effect, a special case
114 -- for ids and partial applications, so that if
115 -- f :: Int -> (forall a. a -> a) -> Int
116 -- then we can infer
117 -- f 3 :: (forall a. a -> a) -> Int
118 -- And that in turn is useful
119 -- (a) for the function part of any application (see tcApp)
120 -- (b) for the special rule for '$'
121 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
122
123 tcInferRhoNC (L loc expr)
124 = setSrcSpan loc $
125 do { (expr', rho) <- tcInfer (tcExpr expr)
126 ; return (L loc expr', rho) }
127
128 tcUnboundId :: OccName -> TcRhoType -> TcM (HsExpr TcId)
129 -- Typechedk an occurrence of an unbound Id
130 --
131 -- Some of these started life as a true hole "_". Others might simply
132 -- be variables that accidentally have no binding site
133 --
134 -- We turn all of them into HsVar, since HsUnboundVar can't contain an
135 -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
136 -- not unbound any more!
137 tcUnboundId occ res_ty
138 = do { ty <- newFlexiTyVarTy liftedTypeKind
139 ; name <- newSysName occ
140 ; let ev = mkLocalId name ty
141 ; loc <- getCtLocM HoleOrigin
142 ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ
143 , cc_hole = ExprHole }
144 ; emitInsoluble can
145 ; tcWrapResult (HsVar ev) ty res_ty }
146
147 {-
148 ************************************************************************
149 * *
150 tcExpr: the main expression typechecker
151 * *
152 ************************************************************************
153 -}
154
155 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
156 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
157 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
158
159 tcExpr (HsVar name) res_ty = tcCheckId name res_ty
160 tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty
161
162 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
163
164 tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
165 ; tcWrapResult (HsLit lit) lit_ty res_ty }
166
167 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
168 ; return (HsPar expr') }
169
170 tcExpr (HsSCC src lbl expr) res_ty
171 = do { expr' <- tcMonoExpr expr res_ty
172 ; return (HsSCC src lbl expr') }
173
174 tcExpr (HsTickPragma src info expr) res_ty
175 = do { expr' <- tcMonoExpr expr res_ty
176 ; return (HsTickPragma src info expr') }
177
178 tcExpr (HsCoreAnn src lbl expr) res_ty
179 = do { expr' <- tcMonoExpr expr res_ty
180 ; return (HsCoreAnn src lbl expr') }
181
182 tcExpr (HsOverLit lit) res_ty
183 = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
184 ; return (HsOverLit lit') }
185
186 tcExpr (NegApp expr neg_expr) res_ty
187 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
188 (mkFunTy res_ty res_ty)
189 ; expr' <- tcMonoExpr expr res_ty
190 ; return (NegApp expr' neg_expr') }
191
192 tcExpr (HsIPVar x) res_ty
193 = do { let origin = IPOccOrigin x
194 ; ipClass <- tcLookupClass ipClassName
195 {- Implicit parameters must have a *tau-type* not a.
196 type scheme. We enforce this by creating a fresh
197 type variable as its type. (Because res_ty may not
198 be a tau-type.) -}
199 ; ip_ty <- newFlexiTyVarTy openTypeKind
200 ; let ip_name = mkStrLitTy (hsIPNameFS x)
201 ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty])
202 ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty }
203 where
204 -- Coerces a dictionary for `IP "x" t` into `t`.
205 fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
206 unwrapIP $ mkClassPred ipClass [x,ty]
207
208 tcExpr (HsLam match) res_ty
209 = do { (co_fn, match') <- tcMatchLambda match res_ty
210 ; return (mkHsWrap co_fn (HsLam match')) }
211
212 tcExpr e@(HsLamCase _ matches) res_ty
213 = do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty
214 ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
215 ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' }
216 where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
217 , ptext (sLit "requires")]
218 match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
219
220 tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
221 = do { nwc_tvs <- mapM newWildcardVarMetaKind wcs
222 ; tcExtendTyVarEnv nwc_tvs $ do {
223 sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
224 ; (gen_fn, expr')
225 <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
226
227 -- Remember to extend the lexical type-variable environment
228 -- See Note [More instantiated than scoped] in TcBinds
229 tcExtendTyVarEnv2
230 [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $
231
232 tcMonoExprNC expr res_ty
233
234 ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
235
236 ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
237 ; addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
238 emitWildcardHoleConstraints (zip wcs nwc_tvs)
239 ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } }
240
241 tcExpr (HsType ty) _
242 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
243 -- This is the syntax for type applications that I was planning
244 -- but there are difficulties (e.g. what order for type args)
245 -- so it's not enabled yet.
246 -- Can't eliminate it altogether from the parser, because the
247 -- same parser parses *patterns*.
248
249 {-
250 ************************************************************************
251 * *
252 Infix operators and sections
253 * *
254 ************************************************************************
255
256 Note [Left sections]
257 ~~~~~~~~~~~~~~~~~~~~
258 Left sections, like (4 *), are equivalent to
259 \ x -> (*) 4 x,
260 or, if PostfixOperators is enabled, just
261 (*) 4
262 With PostfixOperators we don't actually require the function to take
263 two arguments at all. For example, (x `not`) means (not x); you get
264 postfix operators! Not Haskell 98, but it's less work and kind of
265 useful.
266
267 Note [Typing rule for ($)]
268 ~~~~~~~~~~~~~~~~~~~~~~~~~~
269 People write
270 runST $ blah
271 so much, where
272 runST :: (forall s. ST s a) -> a
273 that I have finally given in and written a special type-checking
274 rule just for saturated appliations of ($).
275 * Infer the type of the first argument
276 * Decompose it; should be of form (arg2_ty -> res_ty),
277 where arg2_ty might be a polytype
278 * Use arg2_ty to typecheck arg2
279
280 Note [Typing rule for seq]
281 ~~~~~~~~~~~~~~~~~~~~~~~~~~
282 We want to allow
283 x `seq` (# p,q #)
284 which suggests this type for seq:
285 seq :: forall (a:*) (b:Open). a -> b -> b,
286 with (b:Open) meaning that be can be instantiated with an unboxed
287 tuple. The trouble is that this might accept a partially-applied
288 'seq', and I'm just not certain that would work. I'm only sure it's
289 only going to work when it's fully applied, so it turns into
290 case x of _ -> (# p,q #)
291
292 So it seems more uniform to treat 'seq' as it it was a language
293 construct.
294
295 See Note [seqId magic] in MkId, and
296 -}
297
298 tcExpr (OpApp arg1 op fix arg2) res_ty
299 | (L loc (HsVar op_name)) <- op
300 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
301 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
302 ; let arg2_ty = res_ty
303 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
304 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
305 ; op_id <- tcLookupId op_name
306 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
307 ; return $ OpApp arg1' op' fix arg2' }
308
309 | (L loc (HsVar op_name)) <- op
310 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
311 = do { traceTc "Application rule" (ppr op)
312 ; (arg1', arg1_ty) <- tcInferRho arg1
313
314 ; let doc = ptext (sLit "The first argument of ($) takes")
315 ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
316
317 -- We have (arg1 $ arg2)
318 -- So: arg1_ty = arg2_ty -> op_res_ty
319 -- where arg2_ty maybe polymorphic; that's the point
320
321 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
322 ; co_b <- unifyType op_res_ty res_ty -- op_res ~ res
323
324 -- Make sure that the argument type has kind '*'
325 -- ($) :: forall (a2:*) (r:Open). (a2->r) -> a2 -> r
326 -- Eg we do not want to allow (D# $ 4.0#) Trac #5570
327 -- (which gives a seg fault)
328 -- We do this by unifying with a MetaTv; but of course
329 -- it must allow foralls in the type it unifies with (hence ReturnTv)!
330 --
331 -- The *result* type can have any kind (Trac #8739),
332 -- so we don't need to check anything for that
333 ; a2_tv <- newReturnTyVar liftedTypeKind
334 ; let a2_ty = mkTyVarTy a2_tv
335 ; co_a <- unifyType arg2_ty a2_ty -- arg2 ~ a2
336
337 ; op_id <- tcLookupId op_name
338 ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) (HsVar op_id))
339 ; return $
340 OpApp (mkLHsWrapCo (mkTcFunCo Nominal co_a co_b) $
341 mkLHsWrapCo co_arg1 arg1')
342 op' fix
343 (mkLHsWrapCo co_a arg2') }
344
345 | otherwise
346 = do { traceTc "Non Application rule" (ppr op)
347 ; (op', op_ty) <- tcInferFun op
348 ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
349 ; co_res <- unifyType op_res_ty res_ty
350 ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
351 ; return $ mkHsWrapCo co_res $
352 OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
353
354 -- Right sections, equivalent to \ x -> x `op` expr, or
355 -- \ x -> op x expr
356
357 tcExpr (SectionR op arg2) res_ty
358 = do { (op', op_ty) <- tcInferFun op
359 ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
360 ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
361 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
362 ; return $ mkHsWrapCo co_res $
363 SectionR (mkLHsWrapCo co_fn op') arg2' }
364
365 tcExpr (SectionL arg1 op) res_ty
366 = do { (op', op_ty) <- tcInferFun op
367 ; dflags <- getDynFlags -- Note [Left sections]
368 ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
369 | otherwise = 2
370
371 ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTysWrap op n_reqd_args op_ty
372 ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
373 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
374 ; return $ mkHsWrapCo co_res $
375 SectionL arg1' (mkLHsWrapCo co_fn op') }
376
377 tcExpr (ExplicitTuple tup_args boxity) res_ty
378 | all tupArgPresent tup_args
379 = do { let tup_tc = tupleTyCon boxity (length tup_args)
380 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
381 ; tup_args1 <- tcTupArgs tup_args arg_tys
382 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
383
384 | otherwise
385 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
386 do { let kind = case boxity of { Boxed -> liftedTypeKind
387 ; Unboxed -> openTypeKind }
388 arity = length tup_args
389 tup_tc = tupleTyCon boxity arity
390
391 ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
392 ; let actual_res_ty
393 = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
394 (mkTyConApp tup_tc arg_tys)
395
396 ; coi <- unifyType actual_res_ty res_ty
397
398 -- Handle tuple sections where
399 ; tup_args1 <- tcTupArgs tup_args arg_tys
400
401 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
402
403 tcExpr (ExplicitList _ witness exprs) res_ty
404 = case witness of
405 Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty
406 ; exprs' <- mapM (tc_elt elt_ty) exprs
407 ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') }
408
409 Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind
410 ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty)
411 ; (coi, elt_ty) <- matchExpectedListTy list_ty
412 ; exprs' <- mapM (tc_elt elt_ty) exprs
413 ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') }
414 where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
415
416 tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
417 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
418 ; exprs' <- mapM (tc_elt elt_ty) exprs
419 ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
420 where
421 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
422
423 {-
424 ************************************************************************
425 * *
426 Let, case, if, do
427 * *
428 ************************************************************************
429 -}
430
431 tcExpr (HsLet binds expr) res_ty
432 = do { (binds', expr') <- tcLocalBinds binds $
433 tcMonoExpr expr res_ty
434 ; return (HsLet binds' expr') }
435
436 tcExpr (HsCase scrut matches) exp_ty
437 = do { -- We used to typecheck the case alternatives first.
438 -- The case patterns tend to give good type info to use
439 -- when typechecking the scrutinee. For example
440 -- case (map f) of
441 -- (x:xs) -> ...
442 -- will report that map is applied to too few arguments
443 --
444 -- But now, in the GADT world, we need to typecheck the scrutinee
445 -- first, to get type info that may be refined in the case alternatives
446 (scrut', scrut_ty) <- tcInferRho scrut
447
448 ; traceTc "HsCase" (ppr scrut_ty)
449 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
450 ; return (HsCase scrut' matches') }
451 where
452 match_ctxt = MC { mc_what = CaseAlt,
453 mc_body = tcBody }
454
455 tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
456 = do { pred' <- tcMonoExpr pred boolTy
457 ; b1' <- tcMonoExpr b1 res_ty
458 ; b2' <- tcMonoExpr b2 res_ty
459 ; return (HsIf Nothing pred' b1' b2') }
460
461 tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
462 = do { pred_ty <- newFlexiTyVarTy openTypeKind
463 ; b1_ty <- newFlexiTyVarTy openTypeKind
464 ; b2_ty <- newFlexiTyVarTy openTypeKind
465 ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
466 ; fun' <- tcSyntaxOp IfOrigin fun if_ty
467 ; pred' <- tcMonoExpr pred pred_ty
468 ; b1' <- tcMonoExpr b1 b1_ty
469 ; b2' <- tcMonoExpr b2 b2_ty
470 -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
471 -- so maybe we should use the code for function applications
472 -- (which would allow ifThenElse to be higher rank).
473 -- But it's a little awkward, so I'm leaving it alone for now
474 -- and it maintains uniformity with other rebindable syntax
475 ; return (HsIf (Just fun') pred' b1' b2') }
476
477 tcExpr (HsMultiIf _ alts) res_ty
478 = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
479 ; return $ HsMultiIf res_ty alts' }
480 where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
481
482 tcExpr (HsDo do_or_lc stmts _) res_ty
483 = tcDoStmts do_or_lc stmts res_ty
484
485 tcExpr (HsProc pat cmd) res_ty
486 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
487 ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
488
489 tcExpr (HsStatic expr) res_ty
490 = do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName
491 ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
492 ; (expr', lie) <- captureConstraints $
493 addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
494 2 (ppr expr)
495 ) $
496 tcPolyExprNC expr expr_ty
497 -- Require the type of the argument to be Typeable.
498 -- The evidence is not used, but asking the constraint ensures that
499 -- the current implementation is as restrictive as future versions
500 -- of the StaticPointers extension.
501 ; typeableClass <- tcLookupClass typeableClassName
502 ; _ <- emitWanted StaticOrigin $
503 mkTyConApp (classTyCon typeableClass)
504 [liftedTypeKind, expr_ty]
505 -- Insert the static form in a global list for later validation.
506 ; stWC <- tcg_static_wc <$> getGblEnv
507 ; updTcRef stWC (andWC lie)
508 ; return $ mkHsWrapCo co $ HsStatic expr'
509 }
510
511 {-
512 Note [Rebindable syntax for if]
513 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
514 The rebindable syntax for 'if' uses the most flexible possible type
515 for conditionals:
516 ifThenElse :: p -> b1 -> b2 -> res
517 to support expressions like this:
518
519 ifThenElse :: Maybe a -> (a -> b) -> b -> b
520 ifThenElse (Just a) f _ = f a
521 ifThenElse Nothing _ e = e
522
523 example :: String
524 example = if Just 2
525 then \v -> show v
526 else "No value"
527
528
529 ************************************************************************
530 * *
531 Record construction and update
532 * *
533 ************************************************************************
534 -}
535
536 tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
537 = do { data_con <- tcLookupDataCon con_name
538
539 -- Check for missing fields
540 ; checkMissingFields data_con rbinds
541
542 ; (con_expr, con_tau) <- tcInferId con_name
543 ; let arity = dataConSourceArity data_con
544 (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
545 con_id = dataConWrapId data_con
546
547 ; co_res <- unifyType actual_res_ty res_ty
548 ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
549 ; return $ mkHsWrapCo co_res $
550 RecordCon (L loc con_id) con_expr rbinds' }
551
552 {-
553 Note [Type of a record update]
554 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
555 The main complication with RecordUpd is that we need to explicitly
556 handle the *non-updated* fields. Consider:
557
558 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
559 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
560 | MkT3 { fd :: a }
561
562 upd :: T a b c -> (b',c) -> T a b' c
563 upd t x = t { fb = x}
564
565 The result type should be (T a b' c)
566 not (T a b c), because 'b' *is not* mentioned in a non-updated field
567 not (T a b' c'), because 'c' *is* mentioned in a non-updated field
568 NB that it's not good enough to look at just one constructor; we must
569 look at them all; cf Trac #3219
570
571 After all, upd should be equivalent to:
572 upd t x = case t of
573 MkT1 p q -> MkT1 p x
574 MkT2 a b -> MkT2 p b
575 MkT3 d -> error ...
576
577 So we need to give a completely fresh type to the result record,
578 and then constrain it by the fields that are *not* updated ("p" above).
579 We call these the "fixed" type variables, and compute them in getFixedTyVars.
580
581 Note that because MkT3 doesn't contain all the fields being updated,
582 its RHS is simply an error, so it doesn't impose any type constraints.
583 Hence the use of 'relevant_cont'.
584
585 Note [Implicit type sharing]
586 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
587 We also take into account any "implicit" non-update fields. For example
588 data T a b where { MkT { f::a } :: T a a; ... }
589 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
590
591 Then consider
592 upd t x = t { f=x }
593 We infer the type
594 upd :: T a b -> a -> T a b
595 upd (t::T a b) (x::a)
596 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
597 We can't give it the more general type
598 upd :: T a b -> c -> T c b
599
600 Note [Criteria for update]
601 ~~~~~~~~~~~~~~~~~~~~~~~~~~
602 We want to allow update for existentials etc, provided the updated
603 field isn't part of the existential. For example, this should be ok.
604 data T a where { MkT { f1::a, f2::b->b } :: T a }
605 f :: T a -> b -> T b
606 f t b = t { f1=b }
607
608 The criterion we use is this:
609
610 The types of the updated fields
611 mention only the universally-quantified type variables
612 of the data constructor
613
614 NB: this is not (quite) the same as being a "naughty" record selector
615 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
616 in the case of GADTs. Consider
617 data T a where { MkT :: { f :: a } :: T [a] }
618 Then f is not "naughty" because it has a well-typed record selector.
619 But we don't allow updates for 'f'. (One could consider trying to
620 allow this, but it makes my head hurt. Badly. And no one has asked
621 for it.)
622
623 In principle one could go further, and allow
624 g :: T a -> T a
625 g t = t { f2 = \x -> x }
626 because the expression is polymorphic...but that seems a bridge too far.
627
628 Note [Data family example]
629 ~~~~~~~~~~~~~~~~~~~~~~~~~~
630 data instance T (a,b) = MkT { x::a, y::b }
631 --->
632 data :TP a b = MkT { a::a, y::b }
633 coTP a b :: T (a,b) ~ :TP a b
634
635 Suppose r :: T (t1,t2), e :: t3
636 Then r { x=e } :: T (t3,t1)
637 --->
638 case r |> co1 of
639 MkT x y -> MkT e y |> co2
640 where co1 :: T (t1,t2) ~ :TP t1 t2
641 co2 :: :TP t3 t2 ~ T (t3,t2)
642 The wrapping with co2 is done by the constructor wrapper for MkT
643
644 Outgoing invariants
645 ~~~~~~~~~~~~~~~~~~~
646 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
647
648 * cons are the data constructors to be updated
649
650 * in_inst_tys, out_inst_tys have same length, and instantiate the
651 *representation* tycon of the data cons. In Note [Data
652 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
653 -}
654
655 tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
656 = ASSERT( notNull upd_fld_names )
657 do {
658 -- STEP 0
659 -- Check that the field names are really field names
660 ; sel_ids <- mapM tcLookupField upd_fld_names
661 -- The renamer has already checked that
662 -- selectors are all in scope
663 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
664 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
665 not (isRecordSelector sel_id), -- Excludes class ops
666 let L loc fld_name = hsRecFieldId (unLoc fld) ]
667 ; unless (null bad_guys) (sequence bad_guys >> failM)
668
669 -- STEP 1
670 -- Figure out the tycon and data cons from the first field name
671 ; let -- It's OK to use the non-tc splitters here (for a selector)
672 sel_id : _ = sel_ids
673 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
674 data_cons = tyConDataCons tycon -- it's not a field label
675 -- NB: for a data type family, the tycon is the instance tycon
676
677 relevant_cons = filter is_relevant data_cons
678 is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
679 -- A constructor is only relevant to this process if
680 -- it contains *all* the fields that are being updated
681 -- Other ones will cause a runtime error if they occur
682
683 -- Take apart a representative constructor
684 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
685 (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
686 con1_flds = dataConFieldLabels con1
687 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
688
689 -- Step 2
690 -- Check that at least one constructor has all the named fields
691 -- i.e. has an empty set of bad fields returned by badFields
692 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds data_cons)
693
694 -- STEP 3 Note [Criteria for update]
695 -- Check that each updated field is polymorphic; that is, its type
696 -- mentions only the universally-quantified variables of the data con
697 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
698 upd_flds1_w_tys = filter is_updated flds1_w_tys
699 is_updated (fld,_) = fld `elem` upd_fld_names
700
701 bad_upd_flds = filter bad_fld upd_flds1_w_tys
702 con1_tv_set = mkVarSet con1_tvs
703 bad_fld (fld, ty) = fld `elem` upd_fld_names &&
704 not (tyVarsOfType ty `subVarSet` con1_tv_set)
705 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
706
707 -- STEP 4 Note [Type of a record update]
708 -- Figure out types for the scrutinee and result
709 -- Both are of form (T a b c), with fresh type variables, but with
710 -- common variables where the scrutinee and result must have the same type
711 -- These are variables that appear in *any* arg of *any* of the
712 -- relevant constructors *except* in the updated fields
713 --
714 ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
715 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
716
717 mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType)
718 -- Deals with instantiation of kind variables
719 -- c.f. TcMType.tcInstTyVars
720 mk_inst_ty subst (tv, result_inst_ty)
721 | is_fixed_tv tv -- Same as result type
722 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
723 | otherwise -- Fresh type, of correct kind
724 = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv))
725 ; return (extendTvSubst subst tv new_ty, new_ty) }
726
727 ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs
728 ; let result_inst_tys = mkTyVarTys con1_tvs'
729
730 ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst
731 (con1_tvs `zip` result_inst_tys)
732
733 ; let rec_res_ty = TcType.substTy result_subst con1_res_ty
734 scrut_ty = TcType.substTy scrut_subst con1_res_ty
735 con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
736
737 ; co_res <- unifyType rec_res_ty res_ty
738
739 -- STEP 5
740 -- Typecheck the thing to be updated, and the bindings
741 ; record_expr' <- tcMonoExpr record_expr scrut_ty
742 ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
743
744 -- STEP 6: Deal with the stupid theta
745 ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
746 ; instStupidTheta RecordUpdOrigin theta'
747
748 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
749 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
750 = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys)
751 | otherwise
752 = idHsWrapper
753 -- Phew!
754 ; return $ mkHsWrapCo co_res $
755 RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
756 relevant_cons scrut_inst_tys result_inst_tys }
757 where
758 upd_fld_names = hsRecFields rbinds
759
760 getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
761 -- These tyvars must not change across the updates
762 getFixedTyVars tvs1 cons
763 = mkVarSet [tv1 | con <- cons
764 , let (tvs, theta, arg_tys, _) = dataConSig con
765 flds = dataConFieldLabels con
766 fixed_tvs = exactTyVarsOfTypes fixed_tys
767 -- fixed_tys: See Note [Type of a record update]
768 `unionVarSet` tyVarsOfTypes theta
769 -- Universally-quantified tyvars that
770 -- appear in any of the *implicit*
771 -- arguments to the constructor are fixed
772 -- See Note [Implicit type sharing]
773
774 fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
775 , not (fld `elem` upd_fld_names)]
776 , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs
777 , tv `elemVarSet` fixed_tvs ]
778
779 {-
780 ************************************************************************
781 * *
782 Arithmetic sequences e.g. [a,b..]
783 and their parallel-array counterparts e.g. [: a,b.. :]
784
785 * *
786 ************************************************************************
787 -}
788
789 tcExpr (ArithSeq _ witness seq) res_ty
790 = tcArithSeq witness seq res_ty
791
792 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
793 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
794 ; expr1' <- tcPolyExpr expr1 elt_ty
795 ; expr2' <- tcPolyExpr expr2 elt_ty
796 ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
797 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
798 (idName enumFromToP) elt_ty
799 ; return $ mkHsWrapCo coi
800 (PArrSeq enum_from_to (FromTo expr1' expr2')) }
801
802 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
803 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
804 ; expr1' <- tcPolyExpr expr1 elt_ty
805 ; expr2' <- tcPolyExpr expr2 elt_ty
806 ; expr3' <- tcPolyExpr expr3 elt_ty
807 ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
808 ; eft <- newMethodFromName (PArrSeqOrigin seq)
809 (idName enumFromThenToP) elt_ty -- !!!FIXME: chak
810 ; return $ mkHsWrapCo coi
811 (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
812
813 tcExpr (PArrSeq _ _) _
814 = panic "TcExpr.tcExpr: Infinite parallel array!"
815 -- the parser shouldn't have generated it and the renamer shouldn't have
816 -- let it through
817
818 {-
819 ************************************************************************
820 * *
821 Template Haskell
822 * *
823 ************************************************************************
824 -}
825
826 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
827 tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty
828 tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
829
830 {-
831 ************************************************************************
832 * *
833 Catch-all
834 * *
835 ************************************************************************
836 -}
837
838 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
839 -- Include ArrForm, ArrApp, which shouldn't appear at all
840 -- Also HsTcBracketOut, HsQuasiQuoteE
841
842 {-
843 ************************************************************************
844 * *
845 Arithmetic sequences [a..b] etc
846 * *
847 ************************************************************************
848 -}
849
850 tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
851 -> TcM (HsExpr TcId)
852
853 tcArithSeq witness seq@(From expr) res_ty
854 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
855 ; expr' <- tcPolyExpr expr elt_ty
856 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
857 enumFromName elt_ty
858 ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) }
859
860 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
861 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
862 ; expr1' <- tcPolyExpr expr1 elt_ty
863 ; expr2' <- tcPolyExpr expr2 elt_ty
864 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
865 enumFromThenName elt_ty
866 ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) }
867
868 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
869 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
870 ; expr1' <- tcPolyExpr expr1 elt_ty
871 ; expr2' <- tcPolyExpr expr2 elt_ty
872 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
873 enumFromToName elt_ty
874 ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) }
875
876 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
877 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
878 ; expr1' <- tcPolyExpr expr1 elt_ty
879 ; expr2' <- tcPolyExpr expr2 elt_ty
880 ; expr3' <- tcPolyExpr expr3 elt_ty
881 ; eft <- newMethodFromName (ArithSeqOrigin seq)
882 enumFromThenToName elt_ty
883 ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
884
885 -----------------
886 arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType
887 -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id))
888 arithSeqEltType Nothing res_ty
889 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
890 ; return (coi, elt_ty, Nothing) }
891 arithSeqEltType (Just fl) res_ty
892 = do { list_ty <- newFlexiTyVarTy liftedTypeKind
893 ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
894 ; (coi, elt_ty) <- matchExpectedListTy list_ty
895 ; return (coi, elt_ty, Just fl') }
896
897 {-
898 ************************************************************************
899 * *
900 Applications
901 * *
902 ************************************************************************
903 -}
904
905 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
906 -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
907
908 tcApp (L _ (HsPar e)) args res_ty
909 = tcApp e args res_ty
910
911 tcApp (L _ (HsApp e1 e2)) args res_ty
912 = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
913
914 tcApp (L loc (HsVar fun)) args res_ty
915 | fun `hasKey` tagToEnumKey
916 , [arg] <- args
917 = tcTagToEnum loc fun arg res_ty
918
919 | fun `hasKey` seqIdKey
920 , [arg1,arg2] <- args
921 = tcSeq loc fun arg1 arg2 res_ty
922
923 tcApp fun args res_ty
924 = do { -- Type-check the function
925 ; (fun1, fun_tau) <- tcInferFun fun
926
927 -- Extract its argument types
928 ; (co_fun, expected_arg_tys, actual_res_ty)
929 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
930
931 -- Typecheck the result, thereby propagating
932 -- info (if any) from result into the argument types
933 -- Both actual_res_ty and res_ty are deeply skolemised
934 -- Rather like tcWrapResult, but (perhaps for historical reasons)
935 -- we do this before typechecking the arguments
936 ; wrap_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $
937 tcSubTypeDS_NC GenSigCtxt actual_res_ty res_ty
938
939 -- Typecheck the arguments
940 ; args1 <- tcArgs fun args expected_arg_tys
941
942 -- Assemble the result
943 ; let fun2 = mkLHsWrapCo co_fun fun1
944 app = mkLHsWrap wrap_res (foldl mkHsApp fun2 args1)
945
946 ; return (unLoc app) }
947
948
949 mk_app_msg :: LHsExpr Name -> SDoc
950 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
951 , ptext (sLit "is applied to")]
952
953 ----------------
954 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
955 -- Infer and instantiate the type of a function
956 tcInferFun (L loc (HsVar name))
957 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
958 -- Don't wrap a context around a plain Id
959 ; return (L loc fun, ty) }
960
961 tcInferFun fun
962 = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
963
964 -- Zonk the function type carefully, to expose any polymorphism
965 -- E.g. (( \(x::forall a. a->a). blah ) e)
966 -- We can see the rank-2 type of the lambda in time to generalise e
967 ; fun_ty' <- zonkTcType fun_ty
968
969 ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
970 ; return (mkLHsWrap wrap fun, rho) }
971
972 ----------------
973 tcArgs :: LHsExpr Name -- The function (for error messages)
974 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
975 -> TcM [LHsExpr TcId] -- Resulting args
976
977 tcArgs fun args expected_arg_tys
978 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
979
980 ----------------
981 tcArg :: LHsExpr Name -- The function (for error messages)
982 -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
983 -> TcM (LHsExpr TcId) -- Resulting argument
984 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
985 (tcPolyExprNC arg ty)
986
987 ----------------
988 tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
989 tcTupArgs args tys
990 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
991 where
992 go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
993 go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
994 ; return (L l (Present expr')) }
995
996 ----------------
997 unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType
998 -> TcM (TcCoercion, [TcSigmaType], TcRhoType)
999 -- A wrapper for matchExpectedFunTys
1000 unifyOpFunTysWrap op arity ty = matchExpectedFunTys herald arity ty
1001 where
1002 herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
1003
1004 ---------------------------
1005 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
1006 -- Typecheck a syntax operator, checking that it has the specified type
1007 -- The operator is always a variable at this stage (i.e. renamer output)
1008 -- This version assumes res_ty is a monotype
1009 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
1010 ; tcWrapResult expr rho res_ty }
1011 tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other)
1012
1013 {-
1014 Note [Push result type in]
1015 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1016 Unify with expected result before type-checking the args so that the
1017 info from res_ty percolates to args. This is when we might detect a
1018 too-few args situation. (One can think of cases when the opposite
1019 order would give a better error message.)
1020 experimenting with putting this first.
1021
1022 Here's an example where it actually makes a real difference
1023
1024 class C t a b | t a -> b
1025 instance C Char a Bool
1026
1027 data P t a = forall b. (C t a b) => MkP b
1028 data Q t = MkQ (forall a. P t a)
1029
1030 f1, f2 :: Q Char;
1031 f1 = MkQ (MkP True)
1032 f2 = MkQ (MkP True :: forall a. P Char a)
1033
1034 With the change, f1 will type-check, because the 'Char' info from
1035 the signature is propagated into MkQ's argument. With the check
1036 in the other order, the extra signature in f2 is reqd.
1037
1038
1039 ************************************************************************
1040 * *
1041 tcInferId
1042 * *
1043 ************************************************************************
1044 -}
1045
1046 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
1047 tcCheckId name res_ty
1048 = do { (expr, actual_res_ty) <- tcInferId name
1049 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
1050 ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
1051 tcWrapResult expr actual_res_ty res_ty }
1052
1053 ------------------------
1054 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
1055 -- Infer type, and deeply instantiate
1056 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
1057
1058 ------------------------
1059 tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
1060 -- Look up an occurrence of an Id, and instantiate it (deeply)
1061
1062 tcInferIdWithOrig orig id_name
1063 | id_name `hasKey` tagToEnumKey
1064 = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1065 -- tcApp catches the case (tagToEnum# arg)
1066
1067 | id_name `hasKey` assertIdKey
1068 = do { dflags <- getDynFlags
1069 ; if gopt Opt_IgnoreAsserts dflags
1070 then tc_infer_id orig id_name
1071 else tc_infer_assert dflags orig }
1072
1073 | otherwise
1074 = tc_infer_id orig id_name
1075
1076 tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcRhoType)
1077 -- Deal with an occurrence of 'assert'
1078 -- See Note [Adding the implicit parameter to 'assert']
1079 tc_infer_assert dflags orig
1080 = do { sloc <- getSrcSpanM
1081 ; assert_error_id <- tcLookupId assertErrorName
1082 ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id)
1083 ; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of
1084 Nothing -> pprPanic "assert type" (ppr id_rho)
1085 Just arg_res -> arg_res
1086 ; ASSERT( arg_ty `tcEqType` addrPrimTy )
1087 return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id)))
1088 (L sloc (srcSpanPrimLit dflags sloc))
1089 , res_ty) }
1090
1091 tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
1092 -- Return type is deeply instantiated
1093 tc_infer_id orig id_name
1094 = do { thing <- tcLookup id_name
1095 ; case thing of
1096 ATcId { tct_id = id }
1097 -> do { check_naughty id -- Note [Local record selectors]
1098 ; checkThLocalId id
1099 ; inst_normal_id id }
1100
1101 AGlobal (AnId id)
1102 -> do { check_naughty id
1103 ; inst_normal_id id }
1104 -- A global cannot possibly be ill-staged
1105 -- nor does it need the 'lifting' treatment
1106 -- hence no checkTh stuff here
1107
1108 AGlobal (AConLike cl) -> case cl of
1109 RealDataCon con -> inst_data_con con
1110 PatSynCon ps -> tcPatSynBuilderOcc orig ps
1111
1112 _ -> failWithTc $
1113 ppr thing <+> ptext (sLit "used where a value identifier was expected") }
1114 where
1115 inst_normal_id id
1116 = do { (wrap, rho) <- deeplyInstantiate orig (idType id)
1117 ; return (mkHsWrap wrap (HsVar id), rho) }
1118
1119 inst_data_con con
1120 -- For data constructors,
1121 -- * Must perform the stupid-theta check
1122 -- * No need to deeply instantiate because type has all foralls at top
1123 = do { let wrap_id = dataConWrapId con
1124 (tvs, theta, rho) = tcSplitSigmaTy (idType wrap_id)
1125 ; (subst, tvs') <- tcInstTyVars tvs
1126 ; let tys' = mkTyVarTys tvs'
1127 theta' = substTheta subst theta
1128 rho' = substTy subst rho
1129 ; wrap <- instCall orig tys' theta'
1130 ; addDataConStupidTheta con tys'
1131 ; return (mkHsWrap wrap (HsVar wrap_id), rho') }
1132
1133 check_naughty id
1134 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
1135 | otherwise = return ()
1136
1137 srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
1138 srcSpanPrimLit dflags span
1139 = HsLit (HsStringPrim "" (unsafeMkByteString
1140 (showSDocOneLine dflags (ppr span))))
1141
1142 {-
1143 Note [Adding the implicit parameter to 'assert']
1144 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1145 The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27"
1146 e1 e2). This isn't really the Right Thing because there's no way to
1147 "undo" if you want to see the original source code in the typechecker
1148 output. We'll have fix this in due course, when we care more about
1149 being able to reconstruct the exact original program.
1150
1151 Note [tagToEnum#]
1152 ~~~~~~~~~~~~~~~~~
1153 Nasty check to ensure that tagToEnum# is applied to a type that is an
1154 enumeration TyCon. Unification may refine the type later, but this
1155 check won't see that, alas. It's crude, because it relies on our
1156 knowing *now* that the type is ok, which in turn relies on the
1157 eager-unification part of the type checker pushing enough information
1158 here. In theory the Right Thing to do is to have a new form of
1159 constraint but I definitely cannot face that! And it works ok as-is.
1160
1161 Here's are two cases that should fail
1162 f :: forall a. a
1163 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1164
1165 g :: Int
1166 g = tagToEnum# 0 -- Int is not an enumeration
1167
1168 When data type families are involved it's a bit more complicated.
1169 data family F a
1170 data instance F [Int] = A | B | C
1171 Then we want to generate something like
1172 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1173 Usually that coercion is hidden inside the wrappers for
1174 constructors of F [Int] but here we have to do it explicitly.
1175
1176 It's all grotesquely complicated.
1177 -}
1178
1179 tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name
1180 -> TcRhoType -> TcM (HsExpr TcId)
1181 -- (seq e1 e2) :: res_ty
1182 -- We need a special typing rule because res_ty can be unboxed
1183 -- See Note [Typing rule for seq]
1184 tcSeq loc fun_name arg1 arg2 res_ty
1185 = do { fun <- tcLookupId fun_name
1186 ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1)
1187 ; arg2' <- tcMonoExpr arg2 res_ty
1188 ; let fun' = L loc (HsWrap ty_args (HsVar fun))
1189 ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
1190 ; return (HsApp (L loc (HsApp fun' arg1')) arg2') }
1191
1192 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
1193 -- tagToEnum# :: forall a. Int# -> a
1194 -- See Note [tagToEnum#] Urgh!
1195 tcTagToEnum loc fun_name arg res_ty
1196 = do { fun <- tcLookupId fun_name
1197 ; ty' <- zonkTcType res_ty
1198
1199 -- Check that the type is algebraic
1200 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1201 Just (tc, tc_args) = mb_tc_app
1202 ; checkTc (isJust mb_tc_app)
1203 (mk_error ty' doc1)
1204
1205 -- Look through any type family
1206 ; fam_envs <- tcGetFamInstEnvs
1207 ; let (rep_tc, rep_args, coi) = tcLookupDataFamInst fam_envs tc tc_args
1208 -- coi :: tc tc_args ~R rep_tc rep_args
1209
1210 ; checkTc (isEnumerationTyCon rep_tc)
1211 (mk_error ty' doc2)
1212
1213 ; arg' <- tcMonoExpr arg intPrimTy
1214 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1215 rep_ty = mkTyConApp rep_tc rep_args
1216
1217 ; return (mkHsWrapCoR (mkTcSymCo $ TcCoercion coi) $ HsApp fun' arg') }
1218 -- coi is a Representational coercion
1219 where
1220 doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1221 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1222 doc2 = ptext (sLit "Result type must be an enumeration type")
1223
1224 mk_error :: TcType -> SDoc -> SDoc
1225 mk_error ty what
1226 = hang (ptext (sLit "Bad call to tagToEnum#")
1227 <+> ptext (sLit "at type") <+> ppr ty)
1228 2 what
1229
1230 {-
1231 ************************************************************************
1232 * *
1233 Template Haskell checks
1234 * *
1235 ************************************************************************
1236 -}
1237
1238 checkThLocalId :: Id -> TcM ()
1239 checkThLocalId id
1240 = do { mb_local_use <- getStageAndBindLevel (idName id)
1241 ; case mb_local_use of
1242 Just (top_lvl, bind_lvl, use_stage)
1243 | thLevel use_stage > bind_lvl
1244 , isNotTopLevel top_lvl
1245 -> checkCrossStageLifting id use_stage
1246 _ -> return () -- Not a locally-bound thing, or
1247 -- no cross-stage link
1248 }
1249
1250 --------------------------------------
1251 checkCrossStageLifting :: Id -> ThStage -> TcM ()
1252 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
1253 -- we must check whether there's a cross-stage lift to do
1254 -- Examples \x -> [|| x ||]
1255 -- [|| map ||]
1256 -- There is no error-checking to do, because the renamer did that
1257 --
1258 -- This is similar to checkCrossStageLifting in RnSplice, but
1259 -- this code is applied to *typed* brackets.
1260
1261 checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
1262 = -- Nested identifiers, such as 'x' in
1263 -- E.g. \x -> [|| h x ||]
1264 -- We must behave as if the reference to x was
1265 -- h $(lift x)
1266 -- We use 'x' itself as the splice proxy, used by
1267 -- the desugarer to stitch it all back together.
1268 -- If 'x' occurs many times we may get many identical
1269 -- bindings of the same splice proxy, but that doesn't
1270 -- matter, although it's a mite untidy.
1271 do { let id_ty = idType id
1272 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1273 -- If x is polymorphic, its occurrence sites might
1274 -- have different instantiations, so we can't use plain
1275 -- 'x' as the splice proxy name. I don't know how to
1276 -- solve this, and it's probably unimportant, so I'm
1277 -- just going to flag an error for now
1278
1279 ; lift <- if isStringTy id_ty then
1280 do { sid <- tcLookupId THNames.liftStringName
1281 -- See Note [Lifting strings]
1282 ; return (HsVar sid) }
1283 else
1284 setConstraintVar lie_var $
1285 -- Put the 'lift' constraint into the right LIE
1286 newMethodFromName (OccurrenceOf (idName id))
1287 THNames.liftName id_ty
1288
1289 -- Update the pending splices
1290 ; ps <- readMutVar ps_var
1291 ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
1292 ; writeMutVar ps_var (pending_splice : ps)
1293
1294 ; return () }
1295
1296 checkCrossStageLifting _ _ = return ()
1297
1298 polySpliceErr :: Id -> SDoc
1299 polySpliceErr id
1300 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
1301
1302 {-
1303 Note [Lifting strings]
1304 ~~~~~~~~~~~~~~~~~~~~~~
1305 If we see $(... [| s |] ...) where s::String, we don't want to
1306 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1307 So this conditional short-circuits the lifting mechanism to generate
1308 (liftString "xy") in that case. I didn't want to use overlapping instances
1309 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1310 errors in a polymorphic situation.
1311
1312 If this check fails (which isn't impossible) we get another chance; see
1313 Note [Converting strings] in Convert.hs
1314
1315 Local record selectors
1316 ~~~~~~~~~~~~~~~~~~~~~~
1317 Record selectors for TyCons in this module are ordinary local bindings,
1318 which show up as ATcIds rather than AGlobals. So we need to check for
1319 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1320
1321
1322 ************************************************************************
1323 * *
1324 \subsection{Record bindings}
1325 * *
1326 ************************************************************************
1327
1328 Game plan for record bindings
1329 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1330 1. Find the TyCon for the bindings, from the first field label.
1331
1332 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1333
1334 For each binding field = value
1335
1336 3. Instantiate the field type (from the field label) using the type
1337 envt from step 2.
1338
1339 4 Type check the value using tcArg, passing the field type as
1340 the expected argument type.
1341
1342 This extends OK when the field types are universally quantified.
1343 -}
1344
1345 tcRecordBinds
1346 :: DataCon
1347 -> [TcType] -- Expected type for each field
1348 -> HsRecordBinds Name
1349 -> TcM (HsRecordBinds TcId)
1350
1351 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1352 = do { mb_binds <- mapM do_bind rbinds
1353 ; return (HsRecFields (catMaybes mb_binds) dd) }
1354 where
1355 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1356 do_bind (L l fld@(HsRecField { hsRecFieldId = L loc field_lbl
1357 , hsRecFieldArg = rhs }))
1358 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1359 = addErrCtxt (fieldCtxt field_lbl) $
1360 do { rhs' <- tcPolyExprNC rhs field_ty
1361 ; let field_id = mkUserLocal (nameOccName field_lbl)
1362 (nameUnique field_lbl)
1363 field_ty loc
1364 -- Yuk: the field_id has the *unique* of the selector Id
1365 -- (so we can find it easily)
1366 -- but is a LocalId with the appropriate type of the RHS
1367 -- (so the desugarer knows the type of local binder to make)
1368 ; return (Just (L l (fld { hsRecFieldId = L loc field_id
1369 , hsRecFieldArg = rhs' }))) }
1370 | otherwise
1371 = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
1372 ; return Nothing }
1373
1374 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1375 checkMissingFields data_con rbinds
1376 | null field_labels -- Not declared as a record;
1377 -- But C{} is still valid if no strict fields
1378 = if any isBanged field_strs then
1379 -- Illegal if any arg is strict
1380 addErrTc (missingStrictFields data_con [])
1381 else
1382 return ()
1383
1384 | otherwise = do -- A record
1385 unless (null missing_s_fields)
1386 (addErrTc (missingStrictFields data_con missing_s_fields))
1387
1388 warn <- woptM Opt_WarnMissingFields
1389 unless (not (warn && notNull missing_ns_fields))
1390 (warnTc True (missingFields data_con missing_ns_fields))
1391
1392 where
1393 missing_s_fields
1394 = [ fl | (fl, str) <- field_info,
1395 isBanged str,
1396 not (fl `elem` field_names_used)
1397 ]
1398 missing_ns_fields
1399 = [ fl | (fl, str) <- field_info,
1400 not (isBanged str),
1401 not (fl `elem` field_names_used)
1402 ]
1403
1404 field_names_used = hsRecFields rbinds
1405 field_labels = dataConFieldLabels data_con
1406
1407 field_info = zipEqual "missingFields"
1408 field_labels
1409 field_strs
1410
1411 field_strs = dataConSrcBangs data_con
1412
1413 {-
1414 ************************************************************************
1415 * *
1416 \subsection{Errors and contexts}
1417 * *
1418 ************************************************************************
1419
1420 Boring and alphabetical:
1421 -}
1422
1423 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1424 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1425
1426 exprCtxt :: LHsExpr Name -> SDoc
1427 exprCtxt expr
1428 = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1429
1430 fieldCtxt :: Name -> SDoc
1431 fieldCtxt field_name
1432 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1433
1434 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1435 funAppCtxt fun arg arg_no
1436 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1437 quotes (ppr fun) <> text ", namely"])
1438 2 (quotes (ppr arg))
1439
1440 funResCtxt :: Bool -- There is at least one argument
1441 -> HsExpr Name -> TcType -> TcType
1442 -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1443 -- When we have a mis-match in the return type of a function
1444 -- try to give a helpful message about too many/few arguments
1445 --
1446 -- Used for naked variables too; but with has_args = False
1447 funResCtxt has_args fun fun_res_ty env_ty tidy_env
1448 = do { fun_res' <- zonkTcType fun_res_ty
1449 ; env' <- zonkTcType env_ty
1450 ; let (args_fun, res_fun) = tcSplitFunTys fun_res'
1451 (args_env, res_env) = tcSplitFunTys env'
1452 n_fun = length args_fun
1453 n_env = length args_env
1454 info | n_fun == n_env = Outputable.empty
1455 | n_fun > n_env
1456 , not_fun res_env = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
1457 <+> ptext (sLit "is applied to too few arguments")
1458 | has_args
1459 , not_fun res_fun = ptext (sLit "Possible cause:") <+> quotes (ppr fun)
1460 <+> ptext (sLit "is applied to too many arguments")
1461 | otherwise = Outputable.empty -- Never suggest that a naked variable is
1462 -- applied to too many args!
1463 ; return (tidy_env, info) }
1464 where
1465 not_fun ty -- ty is definitely not an arrow type,
1466 -- and cannot conceivably become one
1467 = case tcSplitTyConApp_maybe ty of
1468 Just (tc, _) -> isAlgTyCon tc
1469 Nothing -> False
1470
1471 badFieldTypes :: [(Name,TcType)] -> SDoc
1472 badFieldTypes prs
1473 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1474 <> plural prs <> colon)
1475 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1476
1477 badFieldsUpd
1478 :: HsRecFields Name a -- Field names that don't belong to a single datacon
1479 -> [DataCon] -- Data cons of the type which the first field name belongs to
1480 -> SDoc
1481 badFieldsUpd rbinds data_cons
1482 = hang (ptext (sLit "No constructor has all these fields:"))
1483 2 (pprQuotedList conflictingFields)
1484 -- See Note [Finding the conflicting fields]
1485 where
1486 -- A (preferably small) set of fields such that no constructor contains
1487 -- all of them. See Note [Finding the conflicting fields]
1488 conflictingFields = case nonMembers of
1489 -- nonMember belongs to a different type.
1490 (nonMember, _) : _ -> [aMember, nonMember]
1491 [] -> let
1492 -- All of rbinds belong to one type. In this case, repeatedly add
1493 -- a field to the set until no constructor contains the set.
1494
1495 -- Each field, together with a list indicating which constructors
1496 -- have all the fields so far.
1497 growingSets :: [(Name, [Bool])]
1498 growingSets = scanl1 combine membership
1499 combine (_, setMem) (field, fldMem)
1500 = (field, zipWith (&&) setMem fldMem)
1501 in
1502 -- Fields that don't change the membership status of the set
1503 -- are redundant and can be dropped.
1504 map (fst . head) $ groupBy ((==) `on` snd) growingSets
1505
1506 aMember = ASSERT( not (null members) ) fst (head members)
1507 (members, nonMembers) = partition (or . snd) membership
1508
1509 -- For each field, which constructors contain the field?
1510 membership :: [(Name, [Bool])]
1511 membership = sortMembership $
1512 map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
1513 hsRecFields rbinds
1514
1515 fieldLabelSets :: [Set.Set Name]
1516 fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons
1517
1518 -- Sort in order of increasing number of True, so that a smaller
1519 -- conflicting set can be found.
1520 sortMembership =
1521 map snd .
1522 sortBy (compare `on` fst) .
1523 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
1524
1525 countTrue = length . filter id
1526
1527 {-
1528 Note [Finding the conflicting fields]
1529 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1530 Suppose we have
1531 data A = A {a0, a1 :: Int}
1532 | B {b0, b1 :: Int}
1533 and we see a record update
1534 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
1535 Then we'd like to find the smallest subset of fields that no
1536 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
1537 We don't really want to report that no constructor has all of
1538 {a0,a1,b0,b1}, because when there are hundreds of fields it's
1539 hard to see what was really wrong.
1540
1541 We may need more than two fields, though; eg
1542 data T = A { x,y :: Int, v::Int }
1543 | B { y,z :: Int, v::Int }
1544 | C { z,x :: Int, v::Int }
1545 with update
1546 r { x=e1, y=e2, z=e3 }, we
1547
1548 Finding the smallest subset is hard, so the code here makes
1549 a decent stab, no more. See Trac #7989.
1550 -}
1551
1552 naughtyRecordSel :: TcId -> SDoc
1553 naughtyRecordSel sel_id
1554 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1555 ptext (sLit "as a function due to escaped type variables") $$
1556 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1557
1558 notSelector :: Name -> SDoc
1559 notSelector field
1560 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1561
1562 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1563 missingStrictFields con fields
1564 = header <> rest
1565 where
1566 rest | null fields = Outputable.empty -- Happens for non-record constructors
1567 -- with strict fields
1568 | otherwise = colon <+> pprWithCommas ppr fields
1569
1570 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1571 ptext (sLit "does not have the required strict field(s)")
1572
1573 missingFields :: DataCon -> [FieldLabel] -> SDoc
1574 missingFields con fields
1575 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1576 <+> pprWithCommas ppr fields
1577
1578 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))