tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
; returnM (HsSCC lbl expr') }
+tcExpr (HsTickPragma info expr) res_ty
+ = do { expr' <- tcMonoExpr expr res_ty
+ ; returnM (HsTickPragma info expr') }
tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
= do { expr' <- tcMonoExpr expr res_ty
where
doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
<+> ptext SLIT("takes one argument")
- tc_args arg1_ty' [arg1_ty, arg2_ty]
- = do { boxyUnify arg1_ty' arg1_ty
- ; tcArg lop (arg2, arg2_ty, 2) }
- tc_args arg1_ty' other = panic "tcExpr SectionR"
+ tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
+ = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty)
+ ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
+ ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
+ ; return (qtys', arg2') }
+ tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
\end{code}
\begin{code}
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+-- For tuples, take care to preserve rigidity
+-- E.g. case (x,y) of ....
+-- The scrutinee should have a rigid type if x,y do
+-- The general scheme is the same as in tcIdApp
tcExpr (ExplicitTuple exprs boxity) res_ty
- = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
- ; exprs' <- tcPolyExprs exprs arg_tys
- ; return (ExplicitTuple exprs' boxity) }
+ = do { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
+ ; let tup_tc = tupleTyCon boxity (length exprs)
+ tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
+ ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
+ ; exprs' <- tcPolyExprs exprs arg_tys
+ ; arg_tys' <- mapM refineBox arg_tys
+ ; co_fn <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
+ ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd') <- tcProc pat cmd res_ty
; checkMissingFields data_con rbinds
; let arity = dataConSourceArity data_con
- check_fields arg_tys
- = do { rbinds' <- tcRecordBinds data_con arg_tys rbinds
- ; mapM unBox arg_tys
- ; return rbinds' }
- -- The unBox ensures that all the boxes in arg_tys are indeed
+ check_fields qtvs qtys arg_tys
+ = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
+ ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
+ ; qtys' <- mapM refineBoxToTau qtys
+ ; return (qtys', rbinds') }
+ -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
-- filled, which is the invariant expected by tcIdApp
+ -- How could this not be the case? Consider a record construction
+ -- that does not mention all the fields.
; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
-- don't know how to do the update otherwise.
-tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
+tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _) res_ty
= -- STEP 0
-- Check that the field names are really field names
ASSERT( notNull rbinds )
-- Figure out the tycon and data cons from the first field name
let
-- It's OK to use the non-tc splitters here (for a selector)
- upd_field_lbls = recBindFields rbinds
+ upd_field_lbls = recBindFields hrbinds
sel_id : _ = sel_ids
(tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
data_cons = tyConDataCons tycon -- it's not a field label
-- Check that at least one constructor has all the named fields
-- i.e. has an empty set of bad fields returned by badFields
checkTc (not (null relevant_cons))
- (badFieldsUpd rbinds) `thenM_`
+ (badFieldsUpd hrbinds) `thenM_`
-- Check that all relevant data cons are vanilla. Doing record updates on
-- GADTs and/or existentials is more than my tiny brain can cope with today
con1_arg_tys' = map (substTy inst_env) con1_arg_tys
in
tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
- tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
+ tcRecordBinds con1 con1_arg_tys' hrbinds `thenM` \ rbinds' ->
-- STEP 5
-- Typecheck the expression to be updated
---------------------------
tcApp :: HsExpr Name -- Function
-> Arity -- Number of args reqd
- -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
+ -> ArgChecker results
-> BoxyRhoType -- Result type
- -> TcM (HsExpr TcId, arg_results)
+ -> TcM (HsExpr TcId, results)
-- (tcFun fun n_args arg_checker res_ty)
-- The argument type checker, arg_checker, will be passed exactly n_args types
= tcIdApp fun_name n_args arg_checker res_ty
tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
- = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
- ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
- ; arg_tys' <- mapM readFilledBox arg_boxes
- ; args' <- arg_checker arg_tys'
+ = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
+ ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
+ ; arg_tys' <- mapM readFilledBox arg_boxes
+ ; (_, args') <- arg_checker [] [] arg_tys' -- Yuk
; return (fun', args') }
---------------------------
tcIdApp :: Name -- Function
-> Arity -- Number of args reqd
- -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
- -- The arg-checker guarantees to fill all boxes in the arg types
+ -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types
-> BoxyRhoType -- Result type
- -> TcM (HsExpr TcId, arg_results)
+ -> TcM (HsExpr TcId, results)
-- Call (f e1 ... en) :: res_ty
-- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
res_ty' = mkFunTys extra_arg_tys' res_ty
; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
- ; let arg_subst = zipOpenTvSubst qtvs qtys'
- fun_arg_tys' = substTys arg_subst fun_arg_tys
-- Typecheck the arguments!
-- Doing so will fill arg_qtvs and extra_arg_tys'
- ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
+ ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
-- Strip boxes from the qtvs that have been filled in by the arg checking
- -- AND any variables that are mentioned in neither arg nor result
- -- the latter are mentioned only in constraints; stripBoxyType will
- -- fill them with a monotype
- ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
- | otherwise = return qty'
- ; qtys'' <- zipWithM strip qtvs qtys'
; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
-- Result subsumption
+ -- This fills in res_qtvs
; let res_subst = zipOpenTvSubst qtvs qtys''
fun_res_ty'' = substTy res_subst fun_res_ty
res_ty'' = mkFunTys extra_arg_tys'' res_ty
-- By applying the coercion just to the *function* we can make
-- tcFun work nicely for OpApp and Sections too
; fun' <- instFun orig fun res_subst tv_theta_prs
- ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
+ ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
; return (mkHsWrap co_fn' fun', args') }
\end{code}
; go True fun ty_theta_prs' }
where
subst_pr (tvs, theta)
- = (map (substTyVar subst) tvs, substTheta subst theta)
+ = (substTyVars subst tvs, substTheta subst theta)
go _ fun [] = return fun
a) it's better for RULEs involving overloaded functions
b) perhaps fewer separated lambdas
+Note [Left to right]
+~~~~~~~~~~~~~~~~~~~~
+tcArgs implements a left-to-right order, which goes beyond what is described in the
+impredicative type inference paper. In particular, it allows
+ runST $ foo
+where runST :: (forall s. ST s a) -> a
+When typechecking the application of ($)::(a->b) -> a -> b, we first check that
+runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type
+before checking foo. The left-to-right order really helps here.
+
\begin{code}
tcArgs :: LHsExpr Name -- The function (for error messages)
- -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
- -> TcM [LHsExpr TcId] -- Resulting args
+ -> [LHsExpr Name] -- Actual args
+ -> ArgChecker [LHsExpr TcId]
-tcArgs fun args expected_arg_tys
- = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
+type ArgChecker results
+ = [TyVar] -> [TcSigmaType] -- Current instantiation
+ -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation)
+ -> TcM ([TcSigmaType], results) -- Resulting instaniation and args
-tcArg :: LHsExpr Name -- The function (for error messages)
- -> (LHsExpr Name, BoxySigmaType, Int) -- Actual argument and expected arg type
- -> TcM (LHsExpr TcId) -- Resulting argument
-tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
- tcPolyExprNC arg ty
+tcArgs fun args qtvs qtys arg_tys
+ = go 1 qtys args arg_tys
+ where
+ go n qtys [] [] = return (qtys, [])
+ go n qtys (arg:args) (arg_ty:arg_tys)
+ = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
+ ; qtys' <- mapM refineBox qtys -- Exploit new info
+ ; (qtys'', args') <- go (n+1) qtys' args arg_tys
+ ; return (qtys'', arg':args') }
+
+tcArg :: LHsExpr Name -- The function
+ -> Int -- and arg number (for error messages)
+ -> LHsExpr Name
+ -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this
+ -> BoxySigmaType
+ -> TcM (LHsExpr TcId) -- Resulting argument
+tcArg fun arg_no arg qtvs qtys ty
+ = addErrCtxt (funAppCtxt fun arg arg_no) $
+ tcPolyExprNC arg (substTyWith qtvs qtys ty)
\end{code}
%************************************************************************
%* *
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
%* *
%************************************************************************
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
-tcRecordBinds data_con arg_tys rbinds
+tcRecordBinds data_con arg_tys (HsRecordBinds rbinds)
= do { mb_binds <- mappM do_bind rbinds
- ; return (catMaybes mb_binds) }
+ ; return (HsRecordBinds (catMaybes mb_binds)) }
where
flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
do_bind (L loc field_lbl, rhs)