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