#endif
import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
- HsMatchContext(..), HsRecordBinds, mkHsApp, mkHsDictApp, mkHsTyApp )
+ HsMatchContext(..), HsRecordBinds,
+ mkHsCoerce, mkHsApp, mkHsDictApp, mkHsTyApp )
import TcHsSyn ( hsLitType )
import TcRnMonad
-import TcUnify ( tcInfer, tcSubExp, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
- boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, unBox )
+import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
+ boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType,
+ unBox )
import BasicTypes ( Arity, isMarkedStrict )
import Inst ( newMethodFromName, newIPDict, instToId,
newDicts, newMethodWithGivenTy, tcInstStupidTheta )
= do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr)
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
- ; return (L (getLoc expr') (HsCoerce gen_fn (unLoc expr'))) }
+ ; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) }
| otherwise
= tcMonoExpr expr res_ty
; co_fn <- tcSubExp ip_ty res_ty
; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
; extendLIE inst
- ; return (HsCoerce co_fn (HsIPVar ip')) }
+ ; return (mkHsCoerce co_fn (HsIPVar ip')) }
tcExpr (HsApp e1 e2) res_ty
= go e1 [e2]
tcExpr (HsLam match) res_ty
= do { (co_fn, match') <- tcMatchLambda match res_ty
- ; return (HsCoerce co_fn (HsLam match')) }
+ ; return (mkHsCoerce co_fn (HsLam match')) }
tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
; expr' <- tcPolyExpr expr sig_tc_ty
; co_fn <- tcSubExp sig_tc_ty res_ty
- ; return (HsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
+ ; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
tcExpr (HsType ty) res_ty
= failWithTc (text "Can't handle type argument:" <+> ppr ty)
tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
= do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
tcApp op 2 (tc_args arg1_ty') res_ty'
- ; return (HsCoerce co_fn (SectionR (L loc op') arg2')) }
+ ; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) }
where
doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
<+> ptext SLIT("takes one argument")
extendLIEs dicts `thenM_`
-- Phew!
- returnM (HsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+ returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
\end{code}
= 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 n_args
+ = 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'
-- Match the result type of the function with the
-- result type of the context, to get an inital substitution
- ; extra_arg_boxes <- newBoxyTyVars n_missing_args
+ ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
res_ty' = mkFunTys extra_arg_tys' res_ty
subst = boxySubMatchType arg_qtvs fun_res_ty res_ty'
; let res_subst = zipOpenTvSubst qtvs qtys''
fun_res_ty'' = substTy res_subst fun_res_ty
res_ty'' = mkFunTys extra_arg_tys'' res_ty
- ; co_fn <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_res_ty'') $
- tcSubExp fun_res_ty'' res_ty''
+ ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
-- And pack up the results
-- By applying the coercion just to the *function* we can make
-- tcFun work nicely for OpApp and Sections too
; fun' <- instFun fun_id qtvs qtys'' tv_theta_prs
; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
- ; return (HsCoerce co_fn' fun', args') }
+ ; return (mkHsCoerce co_fn' fun', args') }
\end{code}
Note [Silly type synonyms in smart-app]
; let res_subst = zipTopTvSubst qtvs qtv_tys
fun_tau' = substTy res_subst fun_tau
- ; co_fn <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_tau') $
- tcSubExp fun_tau' res_ty
+ ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
-- And pack up the results
; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs
- ; return (HsCoerce co_fn fun') }
+ ; return (mkHsCoerce co_fn fun') }
-- Note [Push result type in]
--
-> TcM (LHsExpr TcId) -- Resulting argument
tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
tcPolyExprNC arg ty
-
-
-----------------
--- If an error happens we try to figure out whether the
--- function has been given too many or too few arguments,
--- and say so.
-checkFunResCtxt fun expected_res_ty actual_res_ty tidy_env
- = zonkTcType expected_res_ty `thenM` \ exp_ty' ->
- zonkTcType actual_res_ty `thenM` \ act_ty' ->
- let
- (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
- (env2, act_ty'') = tidyOpenType env1 act_ty'
- (exp_args, _) = tcSplitFunTys exp_ty''
- (act_args, _) = tcSplitFunTys act_ty''
-
- len_act_args = length act_args
- len_exp_args = length exp_args
-
- message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun
- | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun
- | otherwise = empty
- in
- returnM (env2, message)
\end{code}
-- solve this, and it's probably unimportant, so I'm
-- just going to flag an error for now
+ ; id_ty' <- zapToMonotype id_ty
+ -- The id_ty might have an OpenTypeKind, but we
+ -- can't instantiate the Lift class at that kind,
+ -- so we zap it to a LiftedTypeKind monotype
+ -- C.f. the call in TcPat.newLitInst
+
; setLIEVar lie_var $ do
- { lift <- newMethodFromName orig id_ty DsMeta.liftName
+ { lift <- newMethodFromName orig id_ty' DsMeta.liftName
-- Put the 'lift' constraint into the right LIE
-- Update the pending splices
callCtxt fun args
= ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
-wrongArgsCtxt too_many_or_few fun
- = ptext SLIT("Probable cause:") <+> quotes (ppr fun)
- <+> ptext SLIT("is applied to") <+> text too_many_or_few
- <+> ptext SLIT("arguments")
-
#ifdef GHCI
polySpliceErr :: Id -> SDoc
polySpliceErr id
projects / ghc-hetmet.git / blobdiff