2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[TcExpr]{Typecheck an expression}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
16 tcInferRho, tcInferRhoNC, tcSyntaxOp,
17 addExprErrCtxt ) where
19 #include "HsVersions.h"
21 #ifdef GHCI /* Only if bootstrapped */
22 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
23 import qualified DsMeta
40 import TcIface ( checkWiredInTyCon )
63 import Data.List( partition )
67 %************************************************************************
69 \subsection{Main wrappers}
71 %************************************************************************
74 tcPolyExpr, tcPolyExprNC
75 :: LHsExpr Name -- Expession to type check
76 -> BoxySigmaType -- Expected type (could be a polytpye)
77 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
79 -- tcPolyExpr is a convenient place (frequent but not too frequent) place
80 -- to add context information.
81 -- The NC version does not do so, usually because the caller wants
84 tcPolyExpr expr res_ty
85 = addExprErrCtxt expr $
86 (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
88 tcPolyExprNC expr res_ty
90 = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
91 ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty ->
92 tcPolyExprNC expr res_ty
93 -- Note the recursive call to tcPolyExpr, because the
94 -- type may have multiple layers of for-alls
95 -- E.g. forall a. Eq a => forall b. Ord b => ....
96 ; return (mkLHsWrap gen_fn expr') }
99 = tcMonoExprNC expr res_ty
102 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
103 tcPolyExprs [] [] = return []
104 tcPolyExprs (expr:exprs) (ty:tys)
105 = do { expr' <- tcPolyExpr expr ty
106 ; exprs' <- tcPolyExprs exprs tys
107 ; return (expr':exprs') }
108 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
111 tcMonoExpr, tcMonoExprNC
112 :: LHsExpr Name -- Expression to type check
113 -> BoxyRhoType -- Expected type (could be a type variable)
114 -- Definitely no foralls at the top
115 -- Can contain boxes, which will be filled in
116 -> TcM (LHsExpr TcId)
118 tcMonoExpr expr res_ty
119 = addErrCtxt (exprCtxt expr) $
120 tcMonoExprNC expr res_ty
122 tcMonoExprNC (L loc expr) res_ty
123 = ASSERT( not (isSigmaTy res_ty) )
125 do { expr' <- tcExpr expr res_ty
126 ; return (L loc expr') }
129 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
130 tcInferRho expr = tcInfer (tcMonoExpr expr)
131 tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
135 %************************************************************************
137 tcExpr: the main expression typechecker
139 %************************************************************************
142 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
143 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
144 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
146 tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
148 tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
149 ; coi <- boxyUnify lit_ty res_ty
150 ; return $ mkHsWrapCoI coi (HsLit lit)
153 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
154 ; return (HsPar expr') }
156 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
157 ; return (HsSCC lbl expr') }
158 tcExpr (HsTickPragma info expr) res_ty
159 = do { expr' <- tcMonoExpr expr res_ty
160 ; return (HsTickPragma info expr') }
162 tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
163 = do { expr' <- tcMonoExpr expr res_ty
164 ; return (HsCoreAnn lbl expr') }
166 tcExpr (HsOverLit lit) res_ty
167 = do { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
168 ; return (HsOverLit lit') }
170 tcExpr (NegApp expr neg_expr) res_ty
171 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
172 (mkFunTy res_ty res_ty)
173 ; expr' <- tcMonoExpr expr res_ty
174 ; return (NegApp expr' neg_expr') }
176 tcExpr (HsIPVar ip) res_ty
177 = do { let origin = IPOccOrigin ip
178 -- Implicit parameters must have a *tau-type* not a
179 -- type scheme. We enforce this by creating a fresh
180 -- type variable as its type. (Because res_ty may not
182 ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
183 ; co_fn <- tcSubExp origin ip_ty res_ty
184 ; (ip', inst) <- newIPDict origin ip ip_ty
186 ; return (mkHsWrap co_fn (HsIPVar ip')) }
188 tcExpr (HsApp e1 e2) res_ty
191 go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
192 go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
193 go lfun@(L loc fun) args
194 = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
195 tcApp fun (length args) (tcArgs lfun args) res_ty
196 ; traceTc (text "tcExpr args': " <+> ppr args')
197 ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
199 tcExpr (HsLam match) res_ty
200 = do { (co_fn, match') <- tcMatchLambda match res_ty
201 ; return (mkHsWrap co_fn (HsLam match')) }
203 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
204 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
206 -- Remember to extend the lexical type-variable environment
207 ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty ->
208 tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
209 -- See Note [More instantiated than scoped] in TcBinds
210 tcMonoExprNC expr res_ty
212 ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
213 ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
215 tcExpr (HsType ty) res_ty
216 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
217 -- This is the syntax for type applications that I was planning
218 -- but there are difficulties (e.g. what order for type args)
219 -- so it's not enabled yet.
220 -- Can't eliminate it altogether from the parser, because the
221 -- same parser parses *patterns*.
225 %************************************************************************
227 Infix operators and sections
229 %************************************************************************
232 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
233 = do { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
234 ; return (OpApp arg1' (L loc op') fix arg2') }
236 -- Left sections, equivalent to
240 -- or, if PostfixOperators is enabled, just
243 -- With PostfixOperators we don't
244 -- actually require the function to take two arguments
245 -- at all. For example, (x `not`) means (not x);
246 -- you get postfix operators! Not Haskell 98,
247 -- but it's less work and kind of useful.
249 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
250 = do { dflags <- getDOpts
251 ; if dopt Opt_PostfixOperators dflags
252 then do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
253 ; return (SectionL arg1' (L loc op')) }
256 <- subFunTys doc 1 res_ty Nothing $ \ [arg2_ty'] res_ty' ->
257 do { (op', (arg1', co_arg2)) <- tcApp op 2 (tc_args arg2_ty') res_ty'
258 ; let coi = mkFunTyCoI arg2_ty' co_arg2 res_ty' IdCo
259 ; return (mkHsWrapCoI coi (SectionL arg1' (L loc op'))) }
260 ; return (mkHsWrap co_fn expr') } }
262 doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
263 <+> ptext (sLit "takes one argument")
264 tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty]
265 = do { co_arg2 <- boxyUnify (substTyWith qtvs qtys arg2_ty) arg2_ty'
266 ; arg1' <- tcArg lop 1 arg1 qtvs qtys arg1_ty
267 ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
268 ; return (qtys', (arg1', co_arg2)) }
269 tc_args _ _ _ _ = panic "tcExpr SectionL"
271 -- Right sections, equivalent to \ x -> x `op` expr, or
274 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
275 = do { (co_fn, expr')
276 <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
277 do { (op', (co_arg1, arg2')) <- tcApp op 2 (tc_args arg1_ty') res_ty'
278 ; let coi = mkFunTyCoI arg1_ty' co_arg1 res_ty' IdCo
279 ; return (mkHsWrapCoI coi $ SectionR (L loc op') arg2') }
280 ; return (mkHsWrap co_fn expr') }
282 doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
283 <+> ptext (sLit "takes one argument")
284 tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
285 = do { co_arg1 <- boxyUnify (substTyWith qtvs qtys arg1_ty) arg1_ty'
286 ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
287 ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
288 ; return (qtys', (co_arg1, arg2')) }
289 tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
291 -- For tuples, take care to preserve rigidity
292 -- E.g. case (x,y) of ....
293 -- The scrutinee should have a rigid type if x,y do
294 -- The general scheme is the same as in tcIdApp
295 tcExpr in_expr@(ExplicitTuple tup_args boxity) res_ty
296 = do { let kind = case boxity of { Boxed -> liftedTypeKind
297 ; Unboxed -> argTypeKind }
298 arity = length tup_args
299 tup_tc = tupleTyCon boxity arity
300 mk_tup_res_ty arg_tys
301 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
302 (mkTyConApp tup_tc arg_tys)
304 ; checkWiredInTyCon tup_tc -- Ensure instances are available
305 ; tvs <- newBoxyTyVars (replicate arity kind)
306 ; let arg_tys1 = map mkTyVarTy tvs
307 ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
309 ; let go (Missing _, arg_ty) = return (Missing arg_ty)
310 go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
311 ; return (Present expr') }
312 ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
314 ; arg_tys3 <- mapM refineBox arg_tys2
315 ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
316 ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }
320 tcExpr (HsLet binds expr) res_ty
321 = do { (binds', expr') <- tcLocalBinds binds $
322 tcMonoExpr expr res_ty
323 ; return (HsLet binds' expr') }
325 tcExpr (HsCase scrut matches) exp_ty
326 = do { -- We used to typecheck the case alternatives first.
327 -- The case patterns tend to give good type info to use
328 -- when typechecking the scrutinee. For example
331 -- will report that map is applied to too few arguments
333 -- But now, in the GADT world, we need to typecheck the scrutinee
334 -- first, to get type info that may be refined in the case alternatives
335 (scrut', scrut_ty) <- tcInferRho scrut
337 ; traceTc (text "HsCase" <+> ppr scrut_ty)
338 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
339 ; return (HsCase scrut' matches') }
341 match_ctxt = MC { mc_what = CaseAlt,
344 tcExpr (HsIf pred b1 b2) res_ty
345 = do { pred' <- tcMonoExpr pred boolTy
346 ; b1' <- tcMonoExpr b1 res_ty
347 ; b2' <- tcMonoExpr b2 res_ty
348 ; return (HsIf pred' b1' b2') }
350 tcExpr (HsDo do_or_lc stmts body _) res_ty
351 = tcDoStmts do_or_lc stmts body res_ty
353 tcExpr in_expr@(ExplicitList _ exprs) res_ty
354 = do { (elt_ty, coi) <- boxySplitListTy res_ty
355 ; exprs' <- mapM (tc_elt elt_ty) exprs
356 ; when (null exprs) (zapToMonotype elt_ty >> return ())
357 -- If there are no expressions in the comprehension
358 -- we must still fill in the box
360 -- The GHC front end never generates an empty ExplicitList
361 -- (instead it generates the [] data constructor) but
362 -- Template Haskell might. We could fix the bit of
363 -- TH that generates ExplicitList, but it seems less
364 -- fragile to just handle the case here.
365 ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
367 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
369 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
370 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
371 ; exprs' <- mapM (tc_elt elt_ty) exprs
372 ; when (null exprs) (zapToMonotype elt_ty >> return ())
373 -- If there are no expressions in the comprehension
374 -- we must still fill in the box
375 -- (Not needed for [] and () becuase they happen
376 -- to parse as data constructors.)
377 ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
379 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
381 tcExpr (HsProc pat cmd) res_ty
382 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
383 ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
385 tcExpr e@(HsArrApp _ _ _ _ _) _
386 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
387 ptext (sLit "was found where an expression was expected")])
389 tcExpr e@(HsArrForm _ _ _) _
390 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
391 ptext (sLit "was found where an expression was expected")])
394 %************************************************************************
396 Record construction and update
398 %************************************************************************
401 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
402 = do { data_con <- tcLookupDataCon con_name
404 -- Check for missing fields
405 ; checkMissingFields data_con rbinds
407 ; let arity = dataConSourceArity data_con
408 check_fields qtvs qtys arg_tys
409 = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
410 ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
411 ; qtys' <- mapM refineBoxToTau qtys
412 ; return (qtys', rbinds') }
413 -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
414 -- filled, which is the invariant expected by tcIdApp
415 -- How could this not be the case? Consider a record construction
416 -- that does not mention all the fields.
418 ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
420 ; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
423 Note [Type of a record update]
424 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
425 The main complication with RecordUpd is that we need to explicitly
426 handle the *non-updated* fields. Consider:
428 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
429 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
432 upd :: T a b c -> (b',c) -> T a b' c
433 upd t x = t { fb = x}
435 The result type should be (T a b' c)
436 not (T a b c), because 'b' *is not* mentioned in a non-updated field
437 not (T a b' c'), becuase 'c' *is* mentioned in a non-updated field
438 NB that it's not good enough to look at just one constructor; we must
439 look at them all; cf Trac #3219
441 After all, upd should be equivalent to:
447 So we need to give a completely fresh type to the result record,
448 and then constrain it by the fields that are *not* updated ("p" above).
449 We call these the "fixed" type variables, and compute them in getFixedTyVars.
451 Note that because MkT3 doesn't contain all the fields being updated,
452 its RHS is simply an error, so it doesn't impose any type constraints.
453 Hence the use of 'relevant_cont'.
455 Note [Implict type sharing]
456 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
457 We also take into account any "implicit" non-update fields. For example
458 data T a b where { MkT { f::a } :: T a a; ... }
459 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
464 upd :: T a b -> a -> T a b
465 upd (t::T a b) (x::a)
466 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
467 We can't give it the more general type
468 upd :: T a b -> c -> T c b
470 Note [Criteria for update]
471 ~~~~~~~~~~~~~~~~~~~~~~~~~~
472 We want to allow update for existentials etc, provided the updated
473 field isn't part of the existential. For example, this should be ok.
474 data T a where { MkT { f1::a, f2::b->b } :: T a }
478 The criterion we use is this:
480 The types of the updated fields
481 mention only the universally-quantified type variables
482 of the data constructor
484 NB: this is not (quite) the same as being a "naughty" record selector
485 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
486 in the case of GADTs. Consider
487 data T a where { MkT :: { f :: a } :: T [a] }
488 Then f is not "naughty" because it has a well-typed record selector.
489 But we don't allow updates for 'f'. (One could consider trying to
490 allow this, but it makes my head hurt. Badly. And no one has asked
493 In principle one could go further, and allow
495 g t = t { f2 = \x -> x }
496 because the expression is polymorphic...but that seems a bridge too far.
498 Note [Data family example]
499 ~~~~~~~~~~~~~~~~~~~~~~~~~~
500 data instance T (a,b) = MkT { x::a, y::b }
502 data :TP a b = MkT { a::a, y::b }
503 coTP a b :: T (a,b) ~ :TP a b
505 Suppose r :: T (t1,t2), e :: t3
506 Then r { x=e } :: T (t3,t1)
509 MkT x y -> MkT e y |> co2
510 where co1 :: T (t1,t2) ~ :TP t1 t2
511 co2 :: :TP t3 t2 ~ T (t3,t2)
512 The wrapping with co2 is done by the constructor wrapper for MkT
516 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
518 * cons are the data constructors to be updated
520 * in_inst_tys, out_inst_tys have same length, and instantiate the
521 *representation* tycon of the data cons. In Note [Data
522 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
525 tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
526 = ASSERT( notNull upd_fld_names )
529 -- Check that the field names are really field names
530 ; sel_ids <- mapM tcLookupField upd_fld_names
531 -- The renamer has already checked that
532 -- selectors are all in scope
533 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
534 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
535 not (isRecordSelector sel_id), -- Excludes class ops
536 let L loc fld_name = hsRecFieldId fld ]
537 ; unless (null bad_guys) (sequence bad_guys >> failM)
540 -- Figure out the tycon and data cons from the first field name
541 ; let -- It's OK to use the non-tc splitters here (for a selector)
543 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
544 data_cons = tyConDataCons tycon -- it's not a field label
545 -- NB: for a data type family, the tycon is the instance tycon
547 relevant_cons = filter is_relevant data_cons
548 is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
549 -- A constructor is only relevant to this process if
550 -- it contains *all* the fields that are being updated
551 -- Other ones will cause a runtime error if they occur
553 -- Take apart a representative constructor
554 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
555 (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
556 con1_flds = dataConFieldLabels con1
557 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
560 -- Check that at least one constructor has all the named fields
561 -- i.e. has an empty set of bad fields returned by badFields
562 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
564 -- STEP 3 Note [Criteria for update]
565 -- Check that each updated field is polymorphic; that is, its type
566 -- mentions only the universally-quantified variables of the data con
567 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
568 (upd_flds1_w_tys, fixed_flds1_w_tys) = partition is_updated flds1_w_tys
569 is_updated (fld,ty) = fld `elem` upd_fld_names
571 bad_upd_flds = filter bad_fld upd_flds1_w_tys
572 con1_tv_set = mkVarSet con1_tvs
573 bad_fld (fld, ty) = fld `elem` upd_fld_names &&
574 not (tyVarsOfType ty `subVarSet` con1_tv_set)
575 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
577 -- STEP 4 Note [Type of a record update]
578 -- Figure out types for the scrutinee and result
579 -- Both are of form (T a b c), with fresh type variables, but with
580 -- common variables where the scrutinee and result must have the same type
581 -- These are variables that appear in *any* arg of *any* of the
582 -- relevant constructors *except* in the updated fields
584 ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
585 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
586 mk_inst_ty tv result_inst_ty
587 | is_fixed_tv tv = return result_inst_ty -- Same as result type
588 | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
590 ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
591 ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
593 ; let result_ty = substTy result_inst_env con1_res_ty
594 con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
595 scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
596 scrut_ty = substTy scrut_subst con1_res_ty
599 -- Typecheck the thing to be updated, and the bindings
600 ; record_expr' <- tcMonoExpr record_expr scrut_ty
601 ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
603 ; let origin = RecordUpdOrigin
604 ; co_fn <- tcSubExp origin result_ty res_ty
606 -- STEP 6: Deal with the stupid theta
607 ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
608 ; instStupidTheta origin theta'
610 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
611 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
612 = WpCast $ mkTyConApp co_con scrut_inst_tys
617 ; return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
618 relevant_cons scrut_inst_tys result_inst_tys)) }
620 upd_fld_names = hsRecFields rbinds
622 getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
623 -- These tyvars must not change across the updates
624 getFixedTyVars tvs1 cons
625 = mkVarSet [tv1 | con <- cons
626 , let (tvs, theta, arg_tys, _) = dataConSig con
627 flds = dataConFieldLabels con
628 fixed_tvs = exactTyVarsOfTypes fixed_tys
629 -- fixed_tys: See Note [Type of a record update]
630 `unionVarSet` tyVarsOfTheta theta
631 -- Universally-quantified tyvars that
632 -- appear in any of the *implicit*
633 -- arguments to the constructor are fixed
634 -- See Note [Implict type sharing]
636 fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
637 , not (fld `elem` upd_fld_names)]
638 , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs
639 , tv `elemVarSet` fixed_tvs ]
642 %************************************************************************
644 Arithmetic sequences e.g. [a,b..]
645 and their parallel-array counterparts e.g. [: a,b.. :]
648 %************************************************************************
651 tcExpr (ArithSeq _ seq@(From expr)) res_ty
652 = do { (elt_ty, coi) <- boxySplitListTy res_ty
653 ; expr' <- tcPolyExpr expr elt_ty
654 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
656 ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) }
658 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
659 = do { (elt_ty, coi) <- boxySplitListTy res_ty
660 ; expr1' <- tcPolyExpr expr1 elt_ty
661 ; expr2' <- tcPolyExpr expr2 elt_ty
662 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
663 elt_ty enumFromThenName
664 ; return $ mkHsWrapCoI coi
665 (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
667 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
668 = do { (elt_ty, coi) <- boxySplitListTy res_ty
669 ; expr1' <- tcPolyExpr expr1 elt_ty
670 ; expr2' <- tcPolyExpr expr2 elt_ty
671 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
672 elt_ty enumFromToName
673 ; return $ mkHsWrapCoI coi
674 (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
676 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
677 = do { (elt_ty, coi) <- boxySplitListTy res_ty
678 ; expr1' <- tcPolyExpr expr1 elt_ty
679 ; expr2' <- tcPolyExpr expr2 elt_ty
680 ; expr3' <- tcPolyExpr expr3 elt_ty
681 ; eft <- newMethodFromName (ArithSeqOrigin seq)
682 elt_ty enumFromThenToName
683 ; return $ mkHsWrapCoI coi
684 (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
686 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
687 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
688 ; expr1' <- tcPolyExpr expr1 elt_ty
689 ; expr2' <- tcPolyExpr expr2 elt_ty
690 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
691 elt_ty enumFromToPName
692 ; return $ mkHsWrapCoI coi
693 (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
695 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
696 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
697 ; expr1' <- tcPolyExpr expr1 elt_ty
698 ; expr2' <- tcPolyExpr expr2 elt_ty
699 ; expr3' <- tcPolyExpr expr3 elt_ty
700 ; eft <- newMethodFromName (PArrSeqOrigin seq)
701 elt_ty enumFromThenToPName
702 ; return $ mkHsWrapCoI coi
703 (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
705 tcExpr (PArrSeq _ _) _
706 = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
707 -- the parser shouldn't have generated it and the renamer shouldn't have
712 %************************************************************************
716 %************************************************************************
719 #ifdef GHCI /* Only if bootstrapped */
720 -- Rename excludes these cases otherwise
721 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
722 tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
724 tcExpr e@(HsQuasiQuoteE _) res_ty =
725 pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
730 %************************************************************************
734 %************************************************************************
737 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
741 %************************************************************************
745 %************************************************************************
748 ---------------------------
749 tcApp :: HsExpr Name -- Function
750 -> Arity -- Number of args reqd
751 -> ArgChecker results
752 -> BoxyRhoType -- Result type
753 -> TcM (HsExpr TcId, results)
755 -- (tcFun fun n_args arg_checker res_ty)
756 -- The argument type checker, arg_checker, will be passed exactly n_args types
758 tcApp (HsVar fun_name) n_args arg_checker res_ty
759 = tcIdApp fun_name n_args arg_checker res_ty
761 tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
762 = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
763 ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
764 ; arg_tys' <- mapM readFilledBox arg_boxes
765 ; (_, args') <- arg_checker [] [] arg_tys' -- Yuk
766 ; return (fun', args') }
768 ---------------------------
769 tcIdApp :: Name -- Function
770 -> Arity -- Number of args reqd
771 -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types
772 -> BoxyRhoType -- Result type
773 -> TcM (HsExpr TcId, results)
775 -- Call (f e1 ... en) :: res_ty
776 -- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
777 -- (where k <= n; fres has the rest)
778 -- NB: if k < n then the function doesn't have enough args, and
779 -- presumably fres is a type variable that we are going to
780 -- instantiate with a function type
782 -- Then fres <= bx_(k+1) -> ... -> bx_n -> res_ty
784 tcIdApp fun_name n_args arg_checker res_ty
785 = do { let orig = OccurrenceOf fun_name
786 ; (fun, fun_ty) <- lookupFun orig fun_name
788 -- Split up the function type
789 ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
790 (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
792 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
793 arg_qtvs = exactTyVarsOfTypes fun_arg_tys
794 res_qtvs = exactTyVarsOfType fun_res_ty
795 -- NB: exactTyVarsOfType. See Note [Silly type synonyms in smart-app]
796 tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
797 k = length fun_arg_tys -- k <= n_args
798 n_missing_args = n_args - k -- Always >= 0
800 -- Match the result type of the function with the
801 -- result type of the context, to get an inital substitution
802 ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
803 ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
804 res_ty' = mkFunTys extra_arg_tys' res_ty
805 ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
807 -- Typecheck the arguments!
808 -- Doing so will fill arg_qtvs and extra_arg_tys'
809 ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
811 -- Strip boxes from the qtvs that have been filled in by the arg checking
812 ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
814 -- Result subsumption
815 -- This fills in res_qtvs
816 ; let res_subst = zipOpenTvSubst qtvs qtys''
817 fun_res_ty'' = substTy res_subst fun_res_ty
818 res_ty'' = mkFunTys extra_arg_tys'' res_ty
819 ; co_fn <- tcSubExp orig fun_res_ty'' res_ty''
821 -- And pack up the results
822 -- By applying the coercion just to the *function* we can make
823 -- tcFun work nicely for OpApp and Sections too
824 ; fun' <- instFun orig fun res_subst tv_theta_prs
825 ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
826 ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun')
827 ; return (mkHsWrap co_fn' fun', args') }
830 Note [Silly type synonyms in smart-app]
831 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
832 When we call sripBoxyType, all of the boxes should be filled
833 in. But we need to be careful about type synonyms:
837 In the call (f x) we'll typecheck x, expecting it to have type
838 (T box). Usually that would fill in the box, but in this case not;
839 because 'a' is discarded by the silly type synonym T. So we must
840 use exactTyVarsOfType to figure out which type variables are free
841 in the argument type.
844 -- tcId is a specialisation of tcIdApp when there are no arguments
845 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
850 -> BoxyRhoType -- Result type
852 tcId orig fun_name res_ty
853 = do { (fun, fun_ty) <- lookupFun orig fun_name
854 ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty))
856 -- Split up the function type
857 ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
858 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
859 tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part
860 ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
862 -- Do the subsumption check wrt the result type
863 ; let res_subst = zipTopTvSubst qtvs qtv_tys
864 fun_tau' = substTy res_subst fun_tau
866 ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys))
868 ; co_fn <- tcSubExp orig fun_tau' res_ty
870 -- And pack up the results
871 ; fun' <- instFun orig fun res_subst tv_theta_prs
872 ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun'))
873 ; return (mkHsWrap co_fn fun') }
875 -- Note [Push result type in]
877 -- Unify with expected result before (was: after) type-checking the args
878 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
879 -- This is when we might detect a too-few args situation.
880 -- (One can think of cases when the opposite order would give
881 -- a better error message.)
882 -- [March 2003: I'm experimenting with putting this first. Here's an
883 -- example where it actually makes a real difference
884 -- class C t a b | t a -> b
885 -- instance C Char a Bool
887 -- data P t a = forall b. (C t a b) => MkP b
888 -- data Q t = MkQ (forall a. P t a)
891 -- f1 = MkQ (MkP True)
892 -- f2 = MkQ (MkP True :: forall a. P Char a)
894 -- With the change, f1 will type-check, because the 'Char' info from
895 -- the signature is propagated into MkQ's argument. With the check
896 -- in the other order, the extra signature in f2 is reqd.]
898 ---------------------------
899 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
900 -- Typecheck a syntax operator, checking that it has the specified type
901 -- The operator is always a variable at this stage (i.e. renamer output)
902 -- This version assumes ty is a monotype
903 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
904 tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
906 ---------------------------
907 instFun :: InstOrigin
909 -> TvSubst -- The instantiating substitution
910 -> [([TyVar], ThetaType)] -- Stuff to instantiate
913 instFun orig fun subst []
914 = return fun -- Common short cut
916 instFun orig fun subst tv_theta_prs
917 = do { let ty_theta_prs' = map subst_pr tv_theta_prs
918 ; traceTc (text "instFun" <+> ppr ty_theta_prs')
919 -- Make two ad-hoc checks
920 ; doStupidChecks fun ty_theta_prs'
922 -- Now do normal instantiation
923 ; method_sharing <- doptM Opt_MethodSharing
924 ; result <- go method_sharing True fun ty_theta_prs'
925 ; traceTc (text "instFun result" <+> ppr result)
929 subst_pr (tvs, theta)
930 = (substTyVars subst tvs, substTheta subst theta)
932 go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
934 go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
935 | want_method_inst method_sharing theta
936 = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
937 ; meth_id <- newMethodWithGivenTy orig fun_id tys
938 ; go method_sharing False (HsVar meth_id) prs }
939 -- Go round with 'False' to prevent further use
940 -- of newMethod: see Note [Multiple instantiation]
942 go method_sharing _ fun ((tys, theta) : prs)
943 = do { co_fn <- instCall orig tys theta
944 ; traceTc (text "go yields co_fn" <+> ppr co_fn)
945 ; go method_sharing False (HsWrap co_fn fun) prs }
947 -- See Note [No method sharing]
948 want_method_inst method_sharing theta = not (null theta) -- Overloaded
952 Note [Multiple instantiation]
953 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
954 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
955 For example, consider
956 f :: forall a. Eq a => forall b. Ord b => a -> b
957 At a call to f, at say [Int, Bool], it's tempting to translate the call to
961 f_m1 :: forall b. Ord b => Int -> b
965 f_m2 = f_m1 Bool dOrdBool
967 But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
968 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
970 But it's entirely possible that f_m2 will continue to float out, because it
971 mentions no type variables. Result, f_m1 isn't in scope.
973 Here's a concrete example that does this (test tc200):
976 f :: Eq b => b -> a -> Int
977 baz :: Eq a => Int -> a -> Int
982 Current solution: only do the "method sharing" thing for the first type/dict
983 application, not for the iterated ones. A horribly subtle point.
985 Note [No method sharing]
986 ~~~~~~~~~~~~~~~~~~~~~~~~
987 The -fno-method-sharing flag controls what happens so far as the LIE
988 is concerned. The default case is that for an overloaded function we
989 generate a "method" Id, and add the Method Inst to the LIE. So you get
992 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
993 If you specify -fno-method-sharing, the dictionary application
994 isn't shared, so we get
996 f = /\a (d:Num a) (x:a) -> (+) a d x x
997 This gets a bit less sharing, but
998 a) it's better for RULEs involving overloaded functions
999 b) perhaps fewer separated lambdas
1001 Note [Left to right]
1002 ~~~~~~~~~~~~~~~~~~~~
1003 tcArgs implements a left-to-right order, which goes beyond what is described in the
1004 impredicative type inference paper. In particular, it allows
1006 where runST :: (forall s. ST s a) -> a
1007 When typechecking the application of ($)::(a->b) -> a -> b, we first check that
1008 runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type
1009 before checking foo. The left-to-right order really helps here.
1012 tcArgs :: LHsExpr Name -- The function (for error messages)
1013 -> [LHsExpr Name] -- Actual args
1014 -> ArgChecker [LHsExpr TcId]
1016 type ArgChecker results
1017 = [TyVar] -> [TcSigmaType] -- Current instantiation
1018 -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation)
1019 -> TcM ([TcSigmaType], results) -- Resulting instantiation and args
1021 tcArgs fun args qtvs qtys arg_tys
1022 = go 1 qtys args arg_tys
1024 go n qtys [] [] = return (qtys, [])
1025 go n qtys (arg:args) (arg_ty:arg_tys)
1026 = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
1027 ; qtys' <- mapM refineBox qtys -- Exploit new info
1028 ; (qtys'', args') <- go (n+1) qtys' args arg_tys
1029 ; return (qtys'', arg':args') }
1030 go n qtys args arg_tys = panic "tcArgs"
1032 tcArg :: LHsExpr Name -- The function
1033 -> Int -- and arg number (for error messages)
1035 -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this
1037 -> TcM (LHsExpr TcId) -- Resulting argument
1038 tcArg fun arg_no arg qtvs qtys ty
1039 = addErrCtxt (funAppCtxt fun arg arg_no) $
1040 tcPolyExprNC arg (substTyWith qtvs qtys ty)
1046 Nasty check to ensure that tagToEnum# is applied to a type that is an
1047 enumeration TyCon. Unification may refine the type later, but this
1048 check won't see that, alas. It's crude but it works.
1050 Here's are two cases that should fail
1052 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1055 g = tagToEnum# 0 -- Int is not an enumeration
1059 doStupidChecks :: HsExpr TcId
1060 -> [([TcType], ThetaType)]
1062 -- Check two tiresome and ad-hoc cases
1063 -- (a) the "stupid theta" for a data con; add the constraints
1064 -- from the "stupid theta" of a data constructor (sigh)
1065 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
1067 doStupidChecks (HsVar fun_id) ((tys,_):_)
1068 | Just con <- isDataConId_maybe fun_id -- (a)
1069 = addDataConStupidTheta con tys
1071 | fun_id `hasKey` tagToEnumKey -- (b)
1072 = do { tys' <- zonkTcTypes tys
1073 ; checkTc (ok tys') (tagToEnumError tys')
1077 ok (ty:tys) = case tcSplitTyConApp_maybe ty of
1078 Just (tc,_) -> isEnumerationTyCon tc
1081 doStupidChecks fun tv_theta_prs
1082 = return () -- The common case
1086 = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type)
1087 2 (vcat [ptext (sLit "Specify the type by giving a type signature"),
1088 ptext (sLit "e.g. (tagToEnum# x) :: Bool")])
1090 at_type | null tys = empty -- Probably never happens
1091 | otherwise = ptext (sLit "at type") <+> ppr (head tys)
1094 %************************************************************************
1096 \subsection{@tcId@ typechecks an identifier occurrence}
1098 %************************************************************************
1101 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
1102 lookupFun orig id_name
1103 = do { thing <- tcLookup id_name
1105 AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
1107 wrap_id = dataConWrapId con
1110 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1111 | otherwise -> return (HsVar id, idType id)
1112 -- A global cannot possibly be ill-staged
1113 -- nor does it need the 'lifting' treatment
1115 ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
1116 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1117 -- Note [Local record selectors]
1119 -> do { thLocalId orig id ty lvl
1121 Unrefineable -> return (HsVar id, ty)
1122 Rigid co -> return (mkHsWrap co (HsVar id), ty)
1123 Wobbly -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty) -- Wobbly, or no free vars
1124 WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)"))
1127 other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
1130 #ifndef GHCI /* GHCI and TH is off */
1131 --------------------------------------
1132 thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
1133 -- Check for cross-stage lifting
1134 thLocalId orig id id_ty bind_lvl
1137 #else /* GHCI and TH is on */
1138 thLocalId orig id id_ty bind_lvl
1139 = do { use_stage <- getStage -- TH case
1140 ; let use_lvl = thLevel use_stage
1141 ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
1142 ; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
1143 ; when (use_lvl > bind_lvl) $
1144 checkCrossStageLifting orig id id_ty bind_lvl use_stage }
1146 --------------------------------------
1147 checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
1148 -- We are inside brackets, and (use_lvl > bind_lvl)
1149 -- Now we must check whether there's a cross-stage lift to do
1150 -- Examples \x -> [| x |]
1153 checkCrossStageLifting _ _ _ _ Comp = return ()
1154 checkCrossStageLifting _ _ _ _ Splice = return ()
1156 checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var)
1158 = -- Top-level identifiers in this module,
1159 -- (which have External Names)
1160 -- are just like the imported case:
1161 -- no need for the 'lifting' treatment
1162 -- E.g. this is fine:
1165 -- But we do need to put f into the keep-alive
1166 -- set, because after desugaring the code will
1167 -- only mention f's *name*, not f itself.
1170 | otherwise -- bind_lvl = outerLevel presumably,
1171 -- but the Id is not bound at top level
1172 = -- Nested identifiers, such as 'x' in
1173 -- E.g. \x -> [| h x |]
1174 -- We must behave as if the reference to x was
1176 -- We use 'x' itself as the splice proxy, used by
1177 -- the desugarer to stitch it all back together.
1178 -- If 'x' occurs many times we may get many identical
1179 -- bindings of the same splice proxy, but that doesn't
1180 -- matter, although it's a mite untidy.
1181 do { checkTc (isTauTy id_ty) (polySpliceErr id)
1182 -- If x is polymorphic, its occurrence sites might
1183 -- have different instantiations, so we can't use plain
1184 -- 'x' as the splice proxy name. I don't know how to
1185 -- solve this, and it's probably unimportant, so I'm
1186 -- just going to flag an error for now
1188 ; id_ty' <- zapToMonotype id_ty
1189 -- The id_ty might have an OpenTypeKind, but we
1190 -- can't instantiate the Lift class at that kind,
1191 -- so we zap it to a LiftedTypeKind monotype
1192 -- C.f. the call in TcPat.newLitInst
1194 ; lift <- if isStringTy id_ty' then
1195 tcLookupId DsMeta.liftStringName
1196 -- See Note [Lifting strings]
1198 setLIEVar lie_var $ do -- Put the 'lift' constraint into the right LIE
1199 newMethodFromName orig id_ty' DsMeta.liftName
1201 -- Update the pending splices
1202 ; ps <- readMutVar ps_var
1203 ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1209 Note [Lifting strings]
1210 ~~~~~~~~~~~~~~~~~~~~~~
1211 If we see $(... [| s |] ...) where s::String, we don't want to
1212 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1213 So this conditional short-circuits the lifting mechanism to generate
1214 (liftString "xy") in that case. I didn't want to use overlapping instances
1215 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1216 errors in a polymorphic situation.
1218 If this check fails (which isn't impossible) we get another chance; see
1219 Note [Converting strings] in Convert.lhs
1221 Local record selectors
1222 ~~~~~~~~~~~~~~~~~~~~~~
1223 Record selectors for TyCons in this module are ordinary local bindings,
1224 which show up as ATcIds rather than AGlobals. So we need to check for
1225 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1228 %************************************************************************
1230 \subsection{Record bindings}
1232 %************************************************************************
1234 Game plan for record bindings
1235 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1236 1. Find the TyCon for the bindings, from the first field label.
1238 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1240 For each binding field = value
1242 3. Instantiate the field type (from the field label) using the type
1245 4 Type check the value using tcArg, passing the field type as
1246 the expected argument type.
1248 This extends OK when the field types are universally quantified.
1254 -> [TcType] -- Expected type for each field
1255 -> HsRecordBinds Name
1256 -> TcM (HsRecordBinds TcId)
1258 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1259 = do { mb_binds <- mapM do_bind rbinds
1260 ; return (HsRecFields (catMaybes mb_binds) dd) }
1262 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1263 do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1264 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1265 = addErrCtxt (fieldCtxt field_lbl) $
1266 do { rhs' <- tcPolyExprNC rhs field_ty
1267 ; let field_id = mkUserLocal (nameOccName field_lbl)
1268 (nameUnique field_lbl)
1270 -- Yuk: the field_id has the *unique* of the selector Id
1271 -- (so we can find it easily)
1272 -- but is a LocalId with the appropriate type of the RHS
1273 -- (so the desugarer knows the type of local binder to make)
1274 ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
1276 = do { addErrTc (badFieldCon data_con field_lbl)
1279 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1280 checkMissingFields data_con rbinds
1281 | null field_labels -- Not declared as a record;
1282 -- But C{} is still valid if no strict fields
1283 = if any isBanged field_strs then
1284 -- Illegal if any arg is strict
1285 addErrTc (missingStrictFields data_con [])
1289 | otherwise = do -- A record
1290 unless (null missing_s_fields)
1291 (addErrTc (missingStrictFields data_con missing_s_fields))
1293 warn <- doptM Opt_WarnMissingFields
1294 unless (not (warn && notNull missing_ns_fields))
1295 (warnTc True (missingFields data_con missing_ns_fields))
1299 = [ fl | (fl, str) <- field_info,
1301 not (fl `elem` field_names_used)
1304 = [ fl | (fl, str) <- field_info,
1306 not (fl `elem` field_names_used)
1309 field_names_used = hsRecFields rbinds
1310 field_labels = dataConFieldLabels data_con
1312 field_info = zipEqual "missingFields"
1316 field_strs = dataConStrictMarks data_con
1319 %************************************************************************
1321 \subsection{Errors and contexts}
1323 %************************************************************************
1325 Boring and alphabetical:
1327 addExprErrCtxt :: OutputableBndr id => LHsExpr id -> TcM a -> TcM a
1328 addExprErrCtxt expr = addErrCtxt (exprCtxt (unLoc expr))
1331 = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
1333 fieldCtxt field_name
1334 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1336 funAppCtxt fun arg arg_no
1337 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1338 quotes (ppr fun) <> text ", namely"])
1339 4 (quotes (ppr arg))
1342 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1343 <> plural prs <> colon)
1344 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1347 = hang (ptext (sLit "No constructor has all these fields:"))
1348 4 (pprQuotedList (hsRecFields rbinds))
1350 naughtyRecordSel sel_id
1351 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1352 ptext (sLit "as a function due to escaped type variables") $$
1353 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1356 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1358 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1359 missingStrictFields con fields
1362 rest | null fields = empty -- Happens for non-record constructors
1363 -- with strict fields
1364 | otherwise = colon <+> pprWithCommas ppr fields
1366 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1367 ptext (sLit "does not have the required strict field(s)")
1369 missingFields :: DataCon -> [FieldLabel] -> SDoc
1370 missingFields con fields
1371 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1372 <+> pprWithCommas ppr fields
1374 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1377 polySpliceErr :: Id -> SDoc
1379 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)