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