2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[TcExpr]{Typecheck an expression}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
15 tcInferRho, tcInferRhoNC,
16 tcSyntaxOp, tcCheckId,
17 addExprErrCtxt ) where
19 #include "HsVersions.h"
21 #ifdef GHCI /* Only if bootstrapped */
22 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
23 import qualified DsMeta
51 import TysPrim( intPrimTy, ecKind )
52 import PrimOp( tagToEnumKey )
66 %************************************************************************
68 \subsection{Main wrappers}
70 %************************************************************************
73 tcPolyExpr, tcPolyExprNC
74 :: LHsExpr Name -- Expression to type check
75 -> TcSigmaType -- Expected type (could be a polytpye)
76 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
78 -- tcPolyExpr is a convenient place (frequent but not too frequent)
79 -- place to add context information.
80 -- The NC version does not do so, usually because the caller wants
83 tcPolyExpr expr res_ty
84 = addExprErrCtxt expr $
85 do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
87 tcPolyExprNC expr res_ty
88 = do { traceTc "tcPolyExprNC" (ppr res_ty)
89 ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
91 ; return (mkLHsWrap gen_fn expr') }
94 tcMonoExpr, tcMonoExprNC
95 :: LHsExpr Name -- Expression to type check
96 -> TcRhoType -- Expected type (could be a type variable)
97 -- Definitely no foralls at the top
100 tcMonoExpr expr res_ty
101 = addErrCtxt (exprCtxt expr) $
102 tcMonoExprNC expr res_ty
104 tcMonoExprNC (L loc expr) res_ty
105 = ASSERT( not (isSigmaTy res_ty) )
107 do { expr' <- tcExpr expr res_ty
108 ; return (L loc expr') }
111 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
112 -- Infer a *rho*-type. This is, in effect, a special case
113 -- for ids and partial applications, so that if
114 -- f :: Int -> (forall a. a -> a) -> Int
116 -- f 3 :: (forall a. a -> a) -> Int
117 -- And that in turn is useful
118 -- (a) for the function part of any application (see tcApp)
119 -- (b) for the special rule for '$'
120 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
122 tcInferRhoNC (L loc expr)
124 do { (expr', rho) <- tcInfExpr expr
125 ; return (L loc expr', rho) }
127 tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType)
128 tcInfExpr (HsVar f) = tcInferId f
129 tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e
130 ; return (HsPar e', ty) }
131 tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]
132 tcInfExpr e = tcInfer (tcExpr e)
136 %************************************************************************
138 tcExpr: the main expression typechecker
140 %************************************************************************
144 updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a
145 updHetMetLevel f comp =
147 (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x)
148 in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } }))
152 addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name
154 addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e))
156 getIdLevel :: Name -> TcM [TyVar]
158 = do { thing <- tcLookup name
160 ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel
164 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
165 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
166 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
168 tcExpr (HsVar name) res_ty = tcCheckId name res_ty
170 tcExpr (HsHetMetBrak _ e) res_ty =
171 do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty
172 ; fresh_ec_name <- newFlexiTyVar ecKind
173 ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
174 $ tcPolyExpr e elt_ty
175 ; unifyType (TyVarTy fresh_ec_name) inferred_name
176 ; return $ mkHsWrapCo coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') }
177 tcExpr (HsHetMetEsc _ _ e) res_ty =
178 do { cur_level <- getHetMetLevel
179 ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
180 $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty])
181 ; ty' <- zonkTcType res_ty
182 ; return $ HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr') }
183 tcExpr (HsHetMetCSP _ e) res_ty =
184 do { cur_level <- getHetMetLevel
185 ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
186 $ tcExpr (unLoc e) res_ty
187 ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') }
189 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
191 tcExpr (HsLit lit) res_ty =
192 getHetMetLevel >>= \lev ->
194 [] -> do { let lit_ty = hsLitType lit
195 ; tcWrapResult (HsLit lit) lit_ty res_ty }
196 (ec:rest) -> let n = case lit of
197 (HsChar c) -> hetmet_guest_char_literal_name
198 (HsString str) -> hetmet_guest_string_literal_name
199 (HsInteger i _) -> hetmet_guest_integer_literal_name
200 (HsInt i) -> hetmet_guest_integer_literal_name
201 _ -> error "literals of this sort are not allowed at depth >0"
202 in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $
203 (HsApp (noLoc $ HsVar n) (noLoc $ HsLit lit))) res_ty
205 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
206 ; return (HsPar expr') }
208 tcExpr (HsSCC lbl expr) res_ty
209 = do { expr' <- tcMonoExpr expr res_ty
210 ; return (HsSCC lbl expr') }
212 tcExpr (HsTickPragma info expr) res_ty
213 = do { expr' <- tcMonoExpr expr res_ty
214 ; return (HsTickPragma info expr') }
216 tcExpr (HsCoreAnn lbl expr) res_ty
217 = do { expr' <- tcMonoExpr expr res_ty
218 ; return (HsCoreAnn lbl expr') }
220 tcExpr (HsOverLit lit) res_ty =
221 getHetMetLevel >>= \lev ->
223 [] -> do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
224 ; return (HsOverLit lit') }
225 (ec:rest) -> let n = case lit of
226 (OverLit { ol_val = HsIntegral i }) -> hetmet_guest_integer_literal_name
227 (OverLit { ol_val = HsIsString fs }) -> hetmet_guest_string_literal_name
228 (OverLit { ol_val = HsFractional f }) -> error "fractional literals not allowed at depth >0"
229 in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $
230 (HsApp (noLoc $ HsVar n) (noLoc $ HsOverLit lit))) res_ty
233 tcExpr (NegApp expr neg_expr) res_ty
234 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
235 (mkFunTy res_ty res_ty)
236 ; expr' <- tcMonoExpr expr res_ty
237 ; return (NegApp expr' neg_expr') }
239 tcExpr (HsIPVar ip) res_ty
240 = do { let origin = IPOccOrigin ip
241 -- Implicit parameters must have a *tau-type* not a
242 -- type scheme. We enforce this by creating a fresh
243 -- type variable as its type. (Because res_ty may not
245 ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
246 ; ip_var <- emitWanted origin (mkIPPred ip ip_ty)
247 ; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty }
249 tcExpr (HsLam match) res_ty
250 = do { (co_fn, match') <- tcMatchLambda match res_ty
251 ; return (mkHsWrap co_fn (HsLam match')) }
253 tcExpr (ExprWithTySig expr sig_ty) res_ty
254 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
256 -- Remember to extend the lexical type-variable environment
258 <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
259 tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
260 -- See Note [More instantiated than scoped] in TcBinds
261 tcMonoExprNC expr res_ty
263 ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
265 ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
266 ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
269 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
270 -- This is the syntax for type applications that I was planning
271 -- but there are difficulties (e.g. what order for type args)
272 -- so it's not enabled yet.
273 -- Can't eliminate it altogether from the parser, because the
274 -- same parser parses *patterns*.
278 %************************************************************************
280 Infix operators and sections
282 %************************************************************************
286 Left sections, like (4 *), are equivalent to
288 or, if PostfixOperators is enabled, just
290 With PostfixOperators we don't actually require the function to take
291 two arguments at all. For example, (x `not`) means (not x); you get
292 postfix operators! Not Haskell 98, but it's less work and kind of
295 Note [Typing rule for ($)]
296 ~~~~~~~~~~~~~~~~~~~~~~~~~~
300 runST :: (forall s. ST s a) -> a
301 that I have finally given in and written a special type-checking
302 rule just for saturated appliations of ($).
303 * Infer the type of the first argument
304 * Decompose it; should be of form (arg2_ty -> res_ty),
305 where arg2_ty might be a polytype
306 * Use arg2_ty to typecheck arg2
308 Note [Typing rule for seq]
309 ~~~~~~~~~~~~~~~~~~~~~~~~~~
312 which suggests this type for seq:
313 seq :: forall (a:*) (b:??). a -> b -> b,
314 with (b:??) meaning that be can be instantiated with an unboxed tuple.
315 But that's ill-kinded! Function arguments can't be unboxed tuples.
316 And indeed, you could not expect to do this with a partially-applied
317 'seq'; it's only going to work when it's fully applied. so it turns
319 case x of _ -> (# p,q #)
321 For a while I slid by by giving 'seq' an ill-kinded type, but then
322 the simplifier eta-reduced an application of seq and Lint blew up
323 with a kind error. It seems more uniform to treat 'seq' as it it
324 was a language construct.
326 See Note [seqId magic] in MkId, and
330 tcExpr (OpApp arg1 op fix arg2) res_ty
331 | (L loc (HsVar op_name)) <- op
332 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
333 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
334 ; let arg2_ty = res_ty
335 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
336 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
337 ; op_id <- tcLookupId op_name
338 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
339 ; return $ OpApp arg1' op' fix arg2' }
341 | (L loc (HsVar op_name)) <- op
342 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
343 = do { traceTc "Application rule" (ppr op)
344 ; (arg1', arg1_ty) <- tcInferRho arg1
345 ; let doc = ptext (sLit "The first argument of ($) takes")
346 ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
347 -- arg2_ty maybe polymorphic; that's the point
348 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
349 ; co_res <- unifyType op_res_ty res_ty
350 ; op_id <- tcLookupId op_name
351 ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
352 ; return $ mkHsWrapCo co_res $
353 OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' }
356 = do { traceTc "Non Application rule" (ppr op)
357 ; (op', op_ty) <- tcInferFun op
358 ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
359 ; co_res <- unifyType op_res_ty res_ty
360 ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
361 ; return $ mkHsWrapCo co_res $
362 OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
364 -- Right sections, equivalent to \ x -> x `op` expr, or
367 tcExpr (SectionR op arg2) res_ty
368 = do { (op', op_ty) <- tcInferFun op
369 ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
370 ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
371 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
372 ; return $ mkHsWrapCo co_res $
373 SectionR (mkLHsWrapCo co_fn op') arg2' }
375 tcExpr (SectionL arg1 op) res_ty
376 = do { (op', op_ty) <- tcInferFun op
377 ; dflags <- getDOpts -- Note [Left sections]
378 ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
381 ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
382 ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
383 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
384 ; return $ mkHsWrapCo co_res $
385 SectionL arg1' (mkLHsWrapCo co_fn op') }
387 tcExpr (ExplicitTuple tup_args boxity) res_ty
388 | all tupArgPresent tup_args
389 = do { let tup_tc = tupleTyCon boxity (length tup_args)
390 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
391 ; tup_args1 <- tcTupArgs tup_args arg_tys
392 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
395 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
396 do { let kind = case boxity of { Boxed -> liftedTypeKind
397 ; Unboxed -> argTypeKind }
398 arity = length tup_args
399 tup_tc = tupleTyCon boxity arity
401 ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
403 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
404 (mkTyConApp tup_tc arg_tys)
406 ; coi <- unifyType actual_res_ty res_ty
408 -- Handle tuple sections where
409 ; tup_args1 <- tcTupArgs tup_args arg_tys
411 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
413 tcExpr (ExplicitList _ exprs) res_ty
414 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
415 ; exprs' <- mapM (tc_elt elt_ty) exprs
416 ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') }
418 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
420 tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
421 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
422 ; exprs' <- mapM (tc_elt elt_ty) exprs
423 ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
425 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
428 %************************************************************************
432 %************************************************************************
435 tcExpr (HsLet binds expr) res_ty
436 = do { (binds', expr') <- tcLocalBinds binds $
437 tcMonoExpr expr res_ty
438 ; return (HsLet binds' expr') }
440 tcExpr (HsCase scrut matches) exp_ty
441 = do { -- We used to typecheck the case alternatives first.
442 -- The case patterns tend to give good type info to use
443 -- when typechecking the scrutinee. For example
446 -- will report that map is applied to too few arguments
448 -- But now, in the GADT world, we need to typecheck the scrutinee
449 -- first, to get type info that may be refined in the case alternatives
450 (scrut', scrut_ty) <- tcInferRho scrut
452 ; traceTc "HsCase" (ppr scrut_ty)
453 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
454 ; return (HsCase scrut' matches') }
456 match_ctxt = MC { mc_what = CaseAlt,
459 tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
460 = do { pred' <- tcMonoExpr pred boolTy
461 ; b1' <- tcMonoExpr b1 res_ty
462 ; b2' <- tcMonoExpr b2 res_ty
463 ; return (HsIf Nothing pred' b1' b2') }
465 tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
466 = do { pred_ty <- newFlexiTyVarTy openTypeKind
467 ; b1_ty <- newFlexiTyVarTy openTypeKind
468 ; b2_ty <- newFlexiTyVarTy openTypeKind
469 ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
470 ; fun' <- tcSyntaxOp IfOrigin fun if_ty
471 ; pred' <- tcMonoExpr pred pred_ty
472 ; b1' <- tcMonoExpr b1 b1_ty
473 ; b2' <- tcMonoExpr b2 b2_ty
474 -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
475 -- so maybe we should use the code for function applications
476 -- (which would allow ifThenElse to be higher rank).
477 -- But it's a little awkward, so I'm leaving it alone for now
478 -- and it maintains uniformity with other rebindable syntax
479 ; return (HsIf (Just fun') pred' b1' b2') }
481 tcExpr (HsDo do_or_lc stmts _) res_ty
482 = tcDoStmts do_or_lc stmts res_ty
484 tcExpr (HsProc pat cmd) res_ty
485 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
486 ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
488 tcExpr e@(HsArrApp _ _ _ _ _) _
489 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
490 ptext (sLit "was found where an expression was expected")])
492 tcExpr e@(HsArrForm _ _ _) _
493 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
494 ptext (sLit "was found where an expression was expected")])
497 Note [Rebindable syntax for if]
498 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
499 The rebindable syntax for 'if' uses the most flexible possible type
501 ifThenElse :: p -> b1 -> b2 -> res
502 to support expressions like this:
504 ifThenElse :: Maybe a -> (a -> b) -> b -> b
505 ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e
513 %************************************************************************
515 Record construction and update
517 %************************************************************************
520 tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
521 = do { data_con <- tcLookupDataCon con_name
523 -- Check for missing fields
524 ; checkMissingFields data_con rbinds
526 ; (con_expr, con_tau) <- tcInferId con_name
527 ; let arity = dataConSourceArity data_con
528 (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
529 con_id = dataConWrapId data_con
531 ; co_res <- unifyType actual_res_ty res_ty
532 ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
533 ; return $ mkHsWrapCo co_res $
534 RecordCon (L loc con_id) con_expr rbinds' }
537 Note [Type of a record update]
538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
539 The main complication with RecordUpd is that we need to explicitly
540 handle the *non-updated* fields. Consider:
542 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
543 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
546 upd :: T a b c -> (b',c) -> T a b' c
547 upd t x = t { fb = x}
549 The result type should be (T a b' c)
550 not (T a b c), because 'b' *is not* mentioned in a non-updated field
551 not (T a b' c'), becuase 'c' *is* mentioned in a non-updated field
552 NB that it's not good enough to look at just one constructor; we must
553 look at them all; cf Trac #3219
555 After all, upd should be equivalent to:
561 So we need to give a completely fresh type to the result record,
562 and then constrain it by the fields that are *not* updated ("p" above).
563 We call these the "fixed" type variables, and compute them in getFixedTyVars.
565 Note that because MkT3 doesn't contain all the fields being updated,
566 its RHS is simply an error, so it doesn't impose any type constraints.
567 Hence the use of 'relevant_cont'.
569 Note [Implict type sharing]
570 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
571 We also take into account any "implicit" non-update fields. For example
572 data T a b where { MkT { f::a } :: T a a; ... }
573 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
578 upd :: T a b -> a -> T a b
579 upd (t::T a b) (x::a)
580 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
581 We can't give it the more general type
582 upd :: T a b -> c -> T c b
584 Note [Criteria for update]
585 ~~~~~~~~~~~~~~~~~~~~~~~~~~
586 We want to allow update for existentials etc, provided the updated
587 field isn't part of the existential. For example, this should be ok.
588 data T a where { MkT { f1::a, f2::b->b } :: T a }
592 The criterion we use is this:
594 The types of the updated fields
595 mention only the universally-quantified type variables
596 of the data constructor
598 NB: this is not (quite) the same as being a "naughty" record selector
599 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
600 in the case of GADTs. Consider
601 data T a where { MkT :: { f :: a } :: T [a] }
602 Then f is not "naughty" because it has a well-typed record selector.
603 But we don't allow updates for 'f'. (One could consider trying to
604 allow this, but it makes my head hurt. Badly. And no one has asked
607 In principle one could go further, and allow
609 g t = t { f2 = \x -> x }
610 because the expression is polymorphic...but that seems a bridge too far.
612 Note [Data family example]
613 ~~~~~~~~~~~~~~~~~~~~~~~~~~
614 data instance T (a,b) = MkT { x::a, y::b }
616 data :TP a b = MkT { a::a, y::b }
617 coTP a b :: T (a,b) ~ :TP a b
619 Suppose r :: T (t1,t2), e :: t3
620 Then r { x=e } :: T (t3,t1)
623 MkT x y -> MkT e y |> co2
624 where co1 :: T (t1,t2) ~ :TP t1 t2
625 co2 :: :TP t3 t2 ~ T (t3,t2)
626 The wrapping with co2 is done by the constructor wrapper for MkT
630 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
632 * cons are the data constructors to be updated
634 * in_inst_tys, out_inst_tys have same length, and instantiate the
635 *representation* tycon of the data cons. In Note [Data
636 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
639 tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
640 = ASSERT( notNull upd_fld_names )
643 -- Check that the field names are really field names
644 ; sel_ids <- mapM tcLookupField upd_fld_names
645 -- The renamer has already checked that
646 -- selectors are all in scope
647 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
648 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
649 not (isRecordSelector sel_id), -- Excludes class ops
650 let L loc fld_name = hsRecFieldId fld ]
651 ; unless (null bad_guys) (sequence bad_guys >> failM)
654 -- Figure out the tycon and data cons from the first field name
655 ; let -- It's OK to use the non-tc splitters here (for a selector)
657 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
658 data_cons = tyConDataCons tycon -- it's not a field label
659 -- NB: for a data type family, the tycon is the instance tycon
661 relevant_cons = filter is_relevant data_cons
662 is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
663 -- A constructor is only relevant to this process if
664 -- it contains *all* the fields that are being updated
665 -- Other ones will cause a runtime error if they occur
667 -- Take apart a representative constructor
668 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
669 (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
670 con1_flds = dataConFieldLabels con1
671 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
674 -- Check that at least one constructor has all the named fields
675 -- i.e. has an empty set of bad fields returned by badFields
676 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
678 -- STEP 3 Note [Criteria for update]
679 -- Check that each updated field is polymorphic; that is, its type
680 -- mentions only the universally-quantified variables of the data con
681 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
682 upd_flds1_w_tys = filter is_updated flds1_w_tys
683 is_updated (fld,_) = fld `elem` upd_fld_names
685 bad_upd_flds = filter bad_fld upd_flds1_w_tys
686 con1_tv_set = mkVarSet con1_tvs
687 bad_fld (fld, ty) = fld `elem` upd_fld_names &&
688 not (tyVarsOfType ty `subVarSet` con1_tv_set)
689 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
691 -- STEP 4 Note [Type of a record update]
692 -- Figure out types for the scrutinee and result
693 -- Both are of form (T a b c), with fresh type variables, but with
694 -- common variables where the scrutinee and result must have the same type
695 -- These are variables that appear in *any* arg of *any* of the
696 -- relevant constructors *except* in the updated fields
698 ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
699 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
700 mk_inst_ty tv result_inst_ty
701 | is_fixed_tv tv = return result_inst_ty -- Same as result type
702 | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
704 ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
705 ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
707 ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty
708 con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
709 scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
710 scrut_ty = TcType.substTy scrut_subst con1_res_ty
712 ; co_res <- unifyType rec_res_ty res_ty
715 -- Typecheck the thing to be updated, and the bindings
716 ; record_expr' <- tcMonoExpr record_expr scrut_ty
717 ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
719 -- STEP 6: Deal with the stupid theta
720 ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
721 ; instStupidTheta RecordUpdOrigin theta'
723 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
724 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
725 = WpCast $ mkAxInstCo co_con scrut_inst_tys
729 ; return $ mkHsWrapCo co_res $
730 RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
731 relevant_cons scrut_inst_tys result_inst_tys }
733 upd_fld_names = hsRecFields rbinds
735 getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
736 -- These tyvars must not change across the updates
737 getFixedTyVars tvs1 cons
738 = mkVarSet [tv1 | con <- cons
739 , let (tvs, theta, arg_tys, _) = dataConSig con
740 flds = dataConFieldLabels con
741 fixed_tvs = exactTyVarsOfTypes fixed_tys
742 -- fixed_tys: See Note [Type of a record update]
743 `unionVarSet` tyVarsOfTheta theta
744 -- Universally-quantified tyvars that
745 -- appear in any of the *implicit*
746 -- arguments to the constructor are fixed
747 -- See Note [Implict type sharing]
749 fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
750 , not (fld `elem` upd_fld_names)]
751 , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs
752 , tv `elemVarSet` fixed_tvs ]
755 %************************************************************************
757 Arithmetic sequences e.g. [a,b..]
758 and their parallel-array counterparts e.g. [: a,b.. :]
761 %************************************************************************
764 tcExpr (ArithSeq _ seq@(From expr)) res_ty
765 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
766 ; expr' <- tcPolyExpr expr elt_ty
767 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
769 ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) }
771 tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
772 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
773 ; expr1' <- tcPolyExpr expr1 elt_ty
774 ; expr2' <- tcPolyExpr expr2 elt_ty
775 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
776 enumFromThenName elt_ty
777 ; return $ mkHsWrapCo coi
778 (ArithSeq enum_from_then (FromThen expr1' expr2')) }
780 tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
781 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
782 ; expr1' <- tcPolyExpr expr1 elt_ty
783 ; expr2' <- tcPolyExpr expr2 elt_ty
784 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
785 enumFromToName elt_ty
786 ; return $ mkHsWrapCo coi
787 (ArithSeq enum_from_to (FromTo expr1' expr2')) }
789 tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
790 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
791 ; expr1' <- tcPolyExpr expr1 elt_ty
792 ; expr2' <- tcPolyExpr expr2 elt_ty
793 ; expr3' <- tcPolyExpr expr3 elt_ty
794 ; eft <- newMethodFromName (ArithSeqOrigin seq)
795 enumFromThenToName elt_ty
796 ; return $ mkHsWrapCo coi
797 (ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
799 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
800 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
801 ; expr1' <- tcPolyExpr expr1 elt_ty
802 ; expr2' <- tcPolyExpr expr2 elt_ty
803 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
804 (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak
805 ; return $ mkHsWrapCo coi
806 (PArrSeq enum_from_to (FromTo expr1' expr2')) }
808 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
809 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
810 ; expr1' <- tcPolyExpr expr1 elt_ty
811 ; expr2' <- tcPolyExpr expr2 elt_ty
812 ; expr3' <- tcPolyExpr expr3 elt_ty
813 ; eft <- newMethodFromName (PArrSeqOrigin seq)
814 (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak
815 ; return $ mkHsWrapCo coi
816 (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
818 tcExpr (PArrSeq _ _) _
819 = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
820 -- the parser shouldn't have generated it and the renamer shouldn't have
825 %************************************************************************
829 %************************************************************************
832 #ifdef GHCI /* Only if bootstrapped */
833 -- Rename excludes these cases otherwise
834 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
835 tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
837 tcExpr e@(HsQuasiQuoteE _) _ =
838 pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
843 %************************************************************************
847 %************************************************************************
850 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
854 %************************************************************************
858 %************************************************************************
861 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
862 -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
864 tcApp (L _ (HsPar e)) args res_ty
865 = tcApp e args res_ty
867 tcApp (L _ (HsApp e1 e2)) args res_ty
868 = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
870 tcApp (L loc (HsVar fun)) args res_ty
871 | fun `hasKey` tagToEnumKey
873 = tcTagToEnum loc fun arg res_ty
875 tcApp fun args res_ty
876 = do { -- Type-check the function
877 ; (fun1, fun_tau) <- tcInferFun fun
879 -- Extract its argument types
880 ; (co_fun, expected_arg_tys, actual_res_ty)
881 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
883 -- Typecheck the result, thereby propagating
884 -- info (if any) from result into the argument types
885 -- Both actual_res_ty and res_ty are deeply skolemised
886 ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
887 unifyType actual_res_ty res_ty
889 -- Typecheck the arguments
890 ; args1 <- tcArgs fun args expected_arg_tys
892 -- Assemble the result
893 ; let fun2 = mkLHsWrapCo co_fun fun1
894 app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1)
896 ; return (unLoc app) }
899 mk_app_msg :: LHsExpr Name -> SDoc
900 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
901 , ptext (sLit "is applied to")]
904 tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
905 -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args
907 tcInferApp (L _ (HsPar e)) args = tcInferApp e args
908 tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args)
910 = -- Very like the tcApp version, except that there is
911 -- no expected result type passed in
912 do { (fun1, fun_tau) <- tcInferFun fun
913 ; (co_fun, expected_arg_tys, actual_res_ty)
914 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
915 ; args1 <- tcArgs fun args expected_arg_tys
916 ; let fun2 = mkLHsWrapCo co_fun fun1
917 app = foldl mkHsApp fun2 args1
918 ; return (unLoc app, actual_res_ty) }
921 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
922 -- Infer and instantiate the type of a function
923 tcInferFun (L loc (HsVar name))
924 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
925 -- Don't wrap a context around a plain Id
926 ; return (L loc fun, ty) }
929 = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
931 -- Zonk the function type carefully, to expose any polymorphism
932 -- E.g. (( \(x::forall a. a->a). blah ) e)
933 -- We can see the rank-2 type of the lambda in time to genrealise e
934 ; fun_ty' <- zonkTcTypeCarefully fun_ty
936 ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
937 ; return (mkLHsWrap wrap fun, rho) }
940 tcArgs :: LHsExpr Name -- The function (for error messages)
941 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
942 -> TcM [LHsExpr TcId] -- Resulting args
944 tcArgs fun args expected_arg_tys
945 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
948 tcArg :: LHsExpr Name -- The function (for error messages)
949 -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
950 -> TcM (LHsExpr TcId) -- Resulting argument
951 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
952 (tcPolyExprNC arg ty)
955 tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
957 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
959 go (Missing {}, arg_ty) = return (Missing arg_ty)
960 go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
961 ; return (Present expr') }
964 unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
965 -> TcM (Coercion, [TcSigmaType], TcRhoType)
966 -- A wrapper for matchExpectedFunTys
967 unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
969 herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
971 ---------------------------
972 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
973 -- Typecheck a syntax operator, checking that it has the specified type
974 -- The operator is always a variable at this stage (i.e. renamer output)
975 -- This version assumes res_ty is a monotype
976 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
977 ; tcWrapResult expr rho res_ty }
978 tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other)
982 Note [Push result type in]
983 ~~~~~~~~~~~~~~~~~~~~~~~~~~
984 Unify with expected result before type-checking the args so that the
985 info from res_ty percolates to args. This is when we might detect a
986 too-few args situation. (One can think of cases when the opposite
987 order would give a better error message.)
988 experimenting with putting this first.
990 Here's an example where it actually makes a real difference
992 class C t a b | t a -> b
993 instance C Char a Bool
995 data P t a = forall b. (C t a b) => MkP b
996 data Q t = MkQ (forall a. P t a)
1000 f2 = MkQ (MkP True :: forall a. P Char a)
1002 With the change, f1 will type-check, because the 'Char' info from
1003 the signature is propagated into MkQ's argument. With the check
1004 in the other order, the extra signature in f2 is reqd.
1007 %************************************************************************
1011 %************************************************************************
1014 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
1015 tcCheckId name res_ty = do { (expr, rho) <- tcInferId name
1016 ; tcWrapResult expr rho res_ty }
1018 ------------------------
1019 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
1020 -- Infer type, and deeply instantiate
1021 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
1023 ------------------------
1024 tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
1025 -- Look up an occurrence of an Id, and instantiate it (deeply)
1027 tcInferIdWithOrig orig id_name =
1028 do { id_level <- getIdLevel id_name
1029 ; cur_level <- getHetMetLevel
1030 ; if (length id_level < length cur_level)
1031 then do { (lhexp, tcrho) <-
1032 tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name))
1033 ; return (unLoc lhexp, tcrho)
1035 else tcInferIdWithOrig' orig id_name
1038 tcInferIdWithOrig' orig id_name =
1039 do { id <- lookup_id
1040 ; (id_expr, id_rho) <- instantiateOuter orig id
1041 ; (wrap, rho) <- deeplyInstantiate orig id_rho
1042 ; return (mkHsWrap wrap id_expr, rho) }
1044 lookup_id :: TcM TcId
1046 = do { thing <- tcLookup id_name
1048 ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel }
1049 -> do { check_naughty id -- Note [Local record selectors]
1050 ; checkThLocalId id lvl
1051 ; current_hetMetLevel <- getHetMetLevel
1053 (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2))
1054 (zip variable_hetMetLevel current_hetMetLevel)
1058 -> do { check_naughty id
1060 -- A global cannot possibly be ill-staged in Template Haskell
1061 -- nor does it need the 'lifting' treatment
1062 -- hence no checkTh stuff here
1064 AGlobal (ADataCon con) -> return (dataConWrapId con)
1066 other -> failWithTc (bad_lookup other) }
1068 bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
1071 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
1072 | otherwise = return ()
1074 ------------------------
1075 instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
1076 -- Do just the first level of instantiation of an Id
1077 -- a) Deal with method sharing
1078 -- b) Deal with stupid checks
1079 -- Only look at the *outer level* of quantification
1080 -- See Note [Multiple instantiation]
1082 instantiateOuter orig id
1083 | null tvs && null theta
1084 = return (HsVar id, tau)
1087 = do { (_, tys, subst) <- tcInstTyVars tvs
1088 ; doStupidChecks id tys
1089 ; let theta' = substTheta subst theta
1090 ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
1091 ; wrap <- instCall orig tys theta'
1092 ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
1094 (tvs, theta, tau) = tcSplitSigmaTy (idType id)
1097 Note [Multiple instantiation]
1098 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1099 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
1100 For example, consider
1101 f :: forall a. Eq a => forall b. Ord b => a -> b
1102 At a call to f, at say [Int, Bool], it's tempting to translate the call to
1106 f_m1 :: forall b. Ord b => Int -> b
1110 f_m2 = f_m1 Bool dOrdBool
1112 But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
1113 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
1115 But it's entirely possible that f_m2 will continue to float out, because it
1116 mentions no type variables. Result, f_m1 isn't in scope.
1118 Here's a concrete example that does this (test tc200):
1121 f :: Eq b => b -> a -> Int
1122 baz :: Eq a => Int -> a -> Int
1124 instance C Int where
1127 Current solution: only do the "method sharing" thing for the first type/dict
1128 application, not for the iterated ones. A horribly subtle point.
1130 Note [No method sharing]
1131 ~~~~~~~~~~~~~~~~~~~~~~~~
1132 The -fno-method-sharing flag controls what happens so far as the LIE
1133 is concerned. The default case is that for an overloaded function we
1134 generate a "method" Id, and add the Method Inst to the LIE. So you get
1136 f :: Num a => a -> a
1137 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
1138 If you specify -fno-method-sharing, the dictionary application
1139 isn't shared, so we get
1140 f :: Num a => a -> a
1141 f = /\a (d:Num a) (x:a) -> (+) a d x x
1142 This gets a bit less sharing, but
1143 a) it's better for RULEs involving overloaded functions
1144 b) perhaps fewer separated lambdas
1147 doStupidChecks :: TcId
1150 -- Check two tiresome and ad-hoc cases
1151 -- (a) the "stupid theta" for a data con; add the constraints
1152 -- from the "stupid theta" of a data constructor (sigh)
1154 doStupidChecks fun_id tys
1155 | Just con <- isDataConId_maybe fun_id -- (a)
1156 = addDataConStupidTheta con tys
1158 | fun_id `hasKey` tagToEnumKey -- (b)
1159 = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1162 = return () -- The common case
1167 Nasty check to ensure that tagToEnum# is applied to a type that is an
1168 enumeration TyCon. Unification may refine the type later, but this
1169 check won't see that, alas. It's crude, because it relies on our
1170 knowing *now* that the type is ok, which in turn relies on the
1171 eager-unification part of the type checker pushing enough information
1172 here. In theory the Right Thing to do is to have a new form of
1173 constraint but I definitely cannot face that! And it works ok as-is.
1175 Here's are two cases that should fail
1177 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1180 g = tagToEnum# 0 -- Int is not an enumeration
1182 When data type families are involved it's a bit more complicated.
1184 data instance F [Int] = A | B | C
1185 Then we want to generate something like
1186 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1187 Usually that coercion is hidden inside the wrappers for
1188 constructors of F [Int] but here we have to do it explicitly.
1190 It's all grotesquely complicated.
1193 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
1194 -- tagToEnum# :: forall a. Int# -> a
1195 -- See Note [tagToEnum#] Urgh!
1196 tcTagToEnum loc fun_name arg res_ty
1197 = do { fun <- tcLookupId fun_name
1198 ; ty' <- zonkTcType res_ty
1200 -- Check that the type is algebraic
1201 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1202 Just (tc, tc_args) = mb_tc_app
1203 ; checkTc (isJust mb_tc_app)
1204 (tagToEnumError ty' doc1)
1206 -- Look through any type family
1207 ; (coi, rep_tc, rep_args) <- get_rep_ty ty' tc tc_args
1209 ; checkTc (isEnumerationTyCon rep_tc)
1210 (tagToEnumError ty' doc2)
1212 ; arg' <- tcMonoExpr arg intPrimTy
1213 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1214 rep_ty = mkTyConApp rep_tc rep_args
1216 ; return (mkHsWrapCo coi $ HsApp fun' arg') }
1218 doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1219 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1220 doc2 = ptext (sLit "Result type must be an enumeration type")
1221 doc3 = ptext (sLit "No family instance for this type")
1223 get_rep_ty :: TcType -> TyCon -> [TcType]
1224 -> TcM (Coercion, TyCon, [TcType])
1225 -- Converts a family type (eg F [a]) to its rep type (eg FList a)
1226 -- and returns a coercion between the two
1227 get_rep_ty ty tc tc_args
1228 | not (isFamilyTyCon tc)
1229 = return (mkReflCo ty, tc, tc_args)
1231 = do { mb_fam <- tcLookupFamInst tc tc_args
1233 Nothing -> failWithTc (tagToEnumError ty doc3)
1234 Just (rep_tc, rep_args)
1235 -> return ( mkSymCo (mkAxInstCo co_tc rep_args)
1236 , rep_tc, rep_args )
1238 co_tc = expectJust "tcTagToEnum" $
1239 tyConFamilyCoercion_maybe rep_tc }
1241 tagToEnumError :: TcType -> SDoc -> SDoc
1242 tagToEnumError ty what
1243 = hang (ptext (sLit "Bad call to tagToEnum#")
1244 <+> ptext (sLit "at type") <+> ppr ty)
1249 %************************************************************************
1251 Template Haskell checks
1253 %************************************************************************
1256 checkThLocalId :: Id -> ThLevel -> TcM ()
1257 #ifndef GHCI /* GHCI and TH is off */
1258 --------------------------------------
1259 -- Check for cross-stage lifting
1260 checkThLocalId _id _bind_lvl
1263 #else /* GHCI and TH is on */
1264 checkThLocalId id bind_lvl
1265 = do { use_stage <- getStage -- TH case
1266 ; let use_lvl = thLevel use_stage
1267 ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
1268 ; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
1269 ; when (use_lvl > bind_lvl) $
1270 checkCrossStageLifting id bind_lvl use_stage }
1272 --------------------------------------
1273 checkCrossStageLifting :: Id -> ThLevel -> ThStage -> TcM ()
1274 -- We are inside brackets, and (use_lvl > bind_lvl)
1275 -- Now we must check whether there's a cross-stage lift to do
1276 -- Examples \x -> [| x |]
1279 checkCrossStageLifting _ _ Comp = return ()
1280 checkCrossStageLifting _ _ Splice = return ()
1282 checkCrossStageLifting id _ (Brack _ ps_var lie_var)
1284 = -- Top-level identifiers in this module,
1285 -- (which have External Names)
1286 -- are just like the imported case:
1287 -- no need for the 'lifting' treatment
1288 -- E.g. this is fine:
1291 -- But we do need to put f into the keep-alive
1292 -- set, because after desugaring the code will
1293 -- only mention f's *name*, not f itself.
1296 | otherwise -- bind_lvl = outerLevel presumably,
1297 -- but the Id is not bound at top level
1298 = -- Nested identifiers, such as 'x' in
1299 -- E.g. \x -> [| h x |]
1300 -- We must behave as if the reference to x was
1302 -- We use 'x' itself as the splice proxy, used by
1303 -- the desugarer to stitch it all back together.
1304 -- If 'x' occurs many times we may get many identical
1305 -- bindings of the same splice proxy, but that doesn't
1306 -- matter, although it's a mite untidy.
1307 do { let id_ty = idType id
1308 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1309 -- If x is polymorphic, its occurrence sites might
1310 -- have different instantiations, so we can't use plain
1311 -- 'x' as the splice proxy name. I don't know how to
1312 -- solve this, and it's probably unimportant, so I'm
1313 -- just going to flag an error for now
1315 ; lift <- if isStringTy id_ty then
1316 do { sid <- tcLookupId DsMeta.liftStringName
1317 -- See Note [Lifting strings]
1318 ; return (HsVar sid) }
1320 setConstraintVar lie_var $ do
1321 -- Put the 'lift' constraint into the right LIE
1322 newMethodFromName (OccurrenceOf (idName id))
1323 DsMeta.liftName id_ty
1325 -- Update the pending splices
1326 ; ps <- readMutVar ps_var
1327 ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps)
1333 Note [Lifting strings]
1334 ~~~~~~~~~~~~~~~~~~~~~~
1335 If we see $(... [| s |] ...) where s::String, we don't want to
1336 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1337 So this conditional short-circuits the lifting mechanism to generate
1338 (liftString "xy") in that case. I didn't want to use overlapping instances
1339 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1340 errors in a polymorphic situation.
1342 If this check fails (which isn't impossible) we get another chance; see
1343 Note [Converting strings] in Convert.lhs
1345 Local record selectors
1346 ~~~~~~~~~~~~~~~~~~~~~~
1347 Record selectors for TyCons in this module are ordinary local bindings,
1348 which show up as ATcIds rather than AGlobals. So we need to check for
1349 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1352 %************************************************************************
1354 \subsection{Record bindings}
1356 %************************************************************************
1358 Game plan for record bindings
1359 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1360 1. Find the TyCon for the bindings, from the first field label.
1362 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1364 For each binding field = value
1366 3. Instantiate the field type (from the field label) using the type
1369 4 Type check the value using tcArg, passing the field type as
1370 the expected argument type.
1372 This extends OK when the field types are universally quantified.
1378 -> [TcType] -- Expected type for each field
1379 -> HsRecordBinds Name
1380 -> TcM (HsRecordBinds TcId)
1382 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1383 = do { mb_binds <- mapM do_bind rbinds
1384 ; return (HsRecFields (catMaybes mb_binds) dd) }
1386 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1387 do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1388 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1389 = addErrCtxt (fieldCtxt field_lbl) $
1390 do { rhs' <- tcPolyExprNC rhs field_ty
1391 ; let field_id = mkUserLocal (nameOccName field_lbl)
1392 (nameUnique field_lbl)
1394 -- Yuk: the field_id has the *unique* of the selector Id
1395 -- (so we can find it easily)
1396 -- but is a LocalId with the appropriate type of the RHS
1397 -- (so the desugarer knows the type of local binder to make)
1398 ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
1400 = do { addErrTc (badFieldCon data_con field_lbl)
1403 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1404 checkMissingFields data_con rbinds
1405 | null field_labels -- Not declared as a record;
1406 -- But C{} is still valid if no strict fields
1407 = if any isBanged field_strs then
1408 -- Illegal if any arg is strict
1409 addErrTc (missingStrictFields data_con [])
1413 | otherwise = do -- A record
1414 unless (null missing_s_fields)
1415 (addErrTc (missingStrictFields data_con missing_s_fields))
1417 warn <- doptM Opt_WarnMissingFields
1418 unless (not (warn && notNull missing_ns_fields))
1419 (warnTc True (missingFields data_con missing_ns_fields))
1423 = [ fl | (fl, str) <- field_info,
1425 not (fl `elem` field_names_used)
1428 = [ fl | (fl, str) <- field_info,
1430 not (fl `elem` field_names_used)
1433 field_names_used = hsRecFields rbinds
1434 field_labels = dataConFieldLabels data_con
1436 field_info = zipEqual "missingFields"
1440 field_strs = dataConStrictMarks data_con
1443 %************************************************************************
1445 \subsection{Errors and contexts}
1447 %************************************************************************
1449 Boring and alphabetical:
1451 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1452 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1454 exprCtxt :: LHsExpr Name -> SDoc
1456 = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1458 fieldCtxt :: Name -> SDoc
1459 fieldCtxt field_name
1460 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1462 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1463 funAppCtxt fun arg arg_no
1464 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1465 quotes (ppr fun) <> text ", namely"])
1466 2 (quotes (ppr arg))
1468 funResCtxt :: LHsExpr Name -> TcType -> TcType
1469 -> TidyEnv -> TcM (TidyEnv, Message)
1470 -- When we have a mis-match in the return type of a function
1471 -- try to give a helpful message about too many/few arguments
1472 funResCtxt fun fun_res_ty res_ty env0
1473 = do { fun_res' <- zonkTcType fun_res_ty
1474 ; res' <- zonkTcType res_ty
1475 ; let n_fun = length (fst (tcSplitFunTys fun_res'))
1476 n_res = length (fst (tcSplitFunTys res'))
1477 what | n_fun > n_res = ptext (sLit "few")
1478 | otherwise = ptext (sLit "many")
1479 extra | n_fun == n_res = empty
1480 | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
1481 <+> ptext (sLit "is applied to too") <+> what
1482 <+> ptext (sLit "arguments")
1483 msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
1484 ; return (env0, msg $$ extra) }
1486 badFieldTypes :: [(Name,TcType)] -> SDoc
1488 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1489 <> plural prs <> colon)
1490 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1492 badFieldsUpd :: HsRecFields Name a -> SDoc
1494 = hang (ptext (sLit "No constructor has all these fields:"))
1495 2 (pprQuotedList (hsRecFields rbinds))
1497 naughtyRecordSel :: TcId -> SDoc
1498 naughtyRecordSel sel_id
1499 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1500 ptext (sLit "as a function due to escaped type variables") $$
1501 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1503 notSelector :: Name -> SDoc
1505 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1507 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1508 missingStrictFields con fields
1511 rest | null fields = empty -- Happens for non-record constructors
1512 -- with strict fields
1513 | otherwise = colon <+> pprWithCommas ppr fields
1515 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1516 ptext (sLit "does not have the required strict field(s)")
1518 missingFields :: DataCon -> [FieldLabel] -> SDoc
1519 missingFields con fields
1520 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1521 <+> pprWithCommas ppr fields
1523 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1526 polySpliceErr :: Id -> SDoc
1528 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)