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