X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=e9f0301b4a6913c8b940fb400623fe2d615c0b05;hp=0d850def51356b9255261195a35d3bebe899e659;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=7de28fe1fe62b9fee93567224584dc7b1095f7db diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 0d850de..e9f0301 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -25,15 +25,15 @@ module TcUnify ( #include "HsVersions.h" -import HsSyn ( ExprCoFn(..), idCoercion, isIdCoercion, (<.>), - mkCoLams, mkCoTyLams, mkCoApps ) +import HsSyn ( HsWrapper(..), idHsWrapper, isIdHsWrapper, (<.>), + mkWpLams, mkWpTyLams, mkWpApps ) import TypeRep ( Type(..), PredType(..) ) import TcMType ( lookupTcTyVar, LookupTyVarResult(..), - tcInstSkolType, tcInstBoxyTyVar, newKindVar, newMetaTyVar, + tcInstBoxyTyVar, newKindVar, newMetaTyVar, newBoxyTyVar, newBoxyTyVarTys, readFilledBox, readMetaTyVar, writeMetaTyVar, newFlexiTyVarTy, - tcInstSkolTyVars, tcInstTyVar, + tcInstSkolTyVars, tcInstTyVar, tcInstSkolType, zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV, readKindVar, writeKindVar ) import TcSimplify ( tcSimplifyCheck ) @@ -53,7 +53,7 @@ import TcType ( TcKind, TcType, TcTyVar, BoxyTyVar, TcTauType, tidyOpenType, tidyOpenTyVar, tidyOpenTyVars, pprType, tidyKind, tidySkolemTyVar, isSkolemTyVar, isSigTyVar, TvSubst, mkTvSubst, zipTyEnv, zipOpenTvSubst, emptyTvSubst, - substTy, substTheta, + substTy, substTheta, lookupTyVar, extendTvSubst ) import Type ( Kind, SimpleKind, KindVar, openTypeKind, liftedTypeKind, unliftedTypeKind, @@ -110,7 +110,7 @@ subFunTys :: SDoc -- Somthing like "The function f has 3 arguments" -> Arity -- Expected # of args -> BoxyRhoType -- res_ty -> ([BoxySigmaType] -> BoxyRhoType -> TcM a) - -> TcM (ExprCoFn, a) + -> TcM (HsWrapper, a) -- Attempt to decompse res_ty to have enough top-level arrows to -- match the number of patterns in the match group -- @@ -148,13 +148,13 @@ subFunTys error_herald n_pats res_ty thing_inside loop n args_so_far res_ty | isSigmaTy res_ty -- Do this before checking n==0, because we -- guarantee to return a BoxyRhoType, not a BoxySigmaType - = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ res_ty' -> + = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ _ res_ty' -> loop n args_so_far res_ty' ; return (gen_fn <.> co_fn, res) } loop 0 args_so_far res_ty = do { res <- thing_inside (reverse args_so_far) res_ty - ; return (idCoercion, res) } + ; return (idHsWrapper, res) } loop n args_so_far (FunTy arg_ty res_ty) = do { (co_fn, res) <- loop (n-1) (arg_ty:args_so_far) res_ty @@ -178,7 +178,7 @@ subFunTys error_herald n_pats res_ty thing_inside Indirect ty -> loop n args_so_far ty Flexi -> do { (res_ty:arg_tys) <- withMetaTvs tv kinds mk_res_ty ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty - ; return (idCoercion, res) } } + ; return (idHsWrapper, res) } } where mk_res_ty (res_ty' : arg_tys') = mkFunTys arg_tys' res_ty' mk_res_ty [] = panic "TcUnify.mk_res_ty1" @@ -594,30 +594,41 @@ expected_ty. \begin{code} ----------------- -tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM ExprCoFn -- Locally used only +tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only -- (tcSub act exp) checks that -- act <= exp tcSubExp actual_ty expected_ty = -- addErrCtxtM (unifyCtxt actual_ty expected_ty) $ -- Adding the error context here leads to some very confusing error - -- messages, such as "can't match foarall a. a->a with forall a. a->a" - -- So instead I'm adding it when moving from tc_sub to u_tys + -- messages, such as "can't match forall a. a->a with forall a. a->a" + -- Example is tcfail165: + -- do var <- newEmptyMVar :: IO (MVar (forall a. Show a => a -> String)) + -- putMVar var (show :: forall a. Show a => a -> String) + -- Here the info does not flow from the 'var' arg of putMVar to its 'show' arg + -- but after zonking it looks as if it does! + -- + -- So instead I'm adding the error context when moving from tc_sub to u_tys + traceTc (text "tcSubExp" <+> ppr actual_ty <+> ppr expected_ty) >> - tc_sub Nothing actual_ty actual_ty False expected_ty expected_ty + tc_sub SubOther actual_ty actual_ty False expected_ty expected_ty -tcFunResTy :: Name -> BoxySigmaType -> BoxySigmaType -> TcM ExprCoFn -- Locally used only +tcFunResTy :: Name -> BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only tcFunResTy fun actual_ty expected_ty = traceTc (text "tcFunResTy" <+> ppr actual_ty <+> ppr expected_ty) >> - tc_sub (Just fun) actual_ty actual_ty False expected_ty expected_ty + tc_sub (SubFun fun) actual_ty actual_ty False expected_ty expected_ty ----------------- -tc_sub :: Maybe Name -- Just fun => we're looking at a function result type +data SubCtxt = SubDone -- Error-context already pushed + | SubFun Name -- Context is tcFunResTy + | SubOther -- Context is something else + +tc_sub :: SubCtxt -- How to add an error-context -> BoxySigmaType -- actual_ty, before expanding synonyms -> BoxySigmaType -- ..and after -> InBox -- True <=> expected_ty is inside a box -> BoxySigmaType -- expected_ty, before -> BoxySigmaType -- ..and after - -> TcM ExprCoFn + -> TcM HsWrapper -- The acual_ty is never inside a box -- IMPORTANT pre-condition: if the args contain foralls, the bound type -- variables are visible non-monadically @@ -625,24 +636,24 @@ tc_sub :: Maybe Name -- Just fun => we're looking at a function result type -- This invariant is needed so that we can "see" the foralls, ad -- e.g. in the SPEC rule where we just use splitSigmaTy -tc_sub mb_fun act_sty act_ty exp_ib exp_sty exp_ty - = tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty +tc_sub sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty + = tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty -- This indirection is just here to make -- it easy to insert a debug trace! -tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty - | Just exp_ty' <- tcView exp_ty = tc_sub mb_fun act_sty act_ty exp_ib exp_sty exp_ty' -tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty - | Just act_ty' <- tcView act_ty = tc_sub mb_fun act_sty act_ty' exp_ib exp_sty exp_ty +tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty + | Just exp_ty' <- tcView exp_ty = tc_sub sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty' +tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty + | Just act_ty' <- tcView act_ty = tc_sub sub_ctxt act_sty act_ty' exp_ib exp_sty exp_ty ----------------------------------- -- Rule SBOXY, plus other cases when act_ty is a type variable -- Just defer to boxy matching -- This rule takes precedence over SKOL! -tc_sub1 mb_fun act_sty (TyVarTy tv) exp_ib exp_sty exp_ty - = do { addErrCtxtM (subCtxt mb_fun act_sty exp_sty) $ +tc_sub1 sub_ctxt act_sty (TyVarTy tv) exp_ib exp_sty exp_ty + = do { addSubCtxt sub_ctxt act_sty exp_sty $ uVar True False tv exp_ib exp_sty exp_ty - ; return idCoercion } + ; return idHsWrapper } ----------------------------------- -- Skolemisation case (rule SKOL) @@ -655,11 +666,11 @@ tc_sub1 mb_fun act_sty (TyVarTy tv) exp_ib exp_sty exp_ty -- g :: Ord b => b->b -- Consider f g ! -tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty +tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty | not exp_ib, -- SKOL does not apply if exp_ty is inside a box isSigmaTy exp_ty - = do { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ body_exp_ty -> - tc_sub mb_fun act_sty act_ty False body_exp_ty body_exp_ty + = do { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ _ body_exp_ty -> + tc_sub sub_ctxt act_sty act_ty False body_exp_ty body_exp_ty ; return (gen_fn <.> co_fn) } where act_tvs = tyVarsOfType act_ty @@ -672,7 +683,7 @@ tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty -- expected_ty: Int -> Int -- co_fn e = e Int dOrdInt -tc_sub1 mb_fun act_sty actual_ty exp_ib exp_sty expected_ty +tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty -- Implements the new SPEC rule in the Appendix of the paper -- "Boxy types: inference for higher rank types and impredicativity" -- (This appendix isn't in the published version.) @@ -698,7 +709,7 @@ tc_sub1 mb_fun act_sty actual_ty exp_ib exp_sty expected_ty ; traceTc (text "tc_sub_spec" <+> vcat [ppr actual_ty, ppr tyvars <+> ppr theta <+> ppr tau, ppr tau']) - ; co_fn2 <- tc_sub mb_fun tau' tau' exp_ib exp_sty expected_ty + ; co_fn2 <- tc_sub sub_ctxt tau' tau' exp_ib exp_sty expected_ty -- Deal with the dictionaries ; co_fn1 <- instCall InstSigOrigin inst_tys (substTheta subst' theta) @@ -706,46 +717,48 @@ tc_sub1 mb_fun act_sty actual_ty exp_ib exp_sty expected_ty ----------------------------------- -- Function case (rule F1) -tc_sub1 mb_fun _ (FunTy act_arg act_res) exp_ib _ (FunTy exp_arg exp_res) - = tc_sub_funs mb_fun act_arg act_res exp_ib exp_arg exp_res +tc_sub1 sub_ctxt act_sty (FunTy act_arg act_res) exp_ib exp_sty (FunTy exp_arg exp_res) + = addSubCtxt sub_ctxt act_sty exp_sty $ + tc_sub_funs act_arg act_res exp_ib exp_arg exp_res -- Function case (rule F2) -tc_sub1 mb_fun act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_tv) +tc_sub1 sub_ctxt act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_tv) | isBoxyTyVar exp_tv - = do { cts <- readMetaTyVar exp_tv + = addSubCtxt sub_ctxt act_sty exp_sty $ + do { cts <- readMetaTyVar exp_tv ; case cts of - Indirect ty -> tc_sub mb_fun act_sty act_ty True exp_sty ty + Indirect ty -> tc_sub SubDone act_sty act_ty True exp_sty ty Flexi -> do { [arg_ty,res_ty] <- withMetaTvs exp_tv fun_kinds mk_res_ty - ; tc_sub_funs mb_fun act_arg act_res True arg_ty res_ty } } + ; tc_sub_funs act_arg act_res True arg_ty res_ty } } where mk_res_ty [arg_ty', res_ty'] = mkFunTy arg_ty' res_ty' mk_res_ty other = panic "TcUnify.mk_res_ty3" fun_kinds = [argTypeKind, openTypeKind] -- Everything else: defer to boxy matching -tc_sub1 mb_fun act_sty actual_ty exp_ib exp_sty expected_ty - = do { addErrCtxtM (subCtxt mb_fun act_sty exp_sty) $ +tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty + = do { addSubCtxt sub_ctxt act_sty exp_sty $ u_tys True False act_sty actual_ty exp_ib exp_sty expected_ty - ; return idCoercion } + ; return idHsWrapper } ----------------------------------- -tc_sub_funs mb_fun act_arg act_res exp_ib exp_arg exp_res +tc_sub_funs act_arg act_res exp_ib exp_arg exp_res = do { uTys False act_arg exp_ib exp_arg - ; co_fn_res <- tc_sub mb_fun act_res act_res exp_ib exp_res exp_res + ; co_fn_res <- tc_sub SubDone act_res act_res exp_ib exp_res exp_res ; wrapFunResCoercion [exp_arg] co_fn_res } ----------------------------------- wrapFunResCoercion :: [TcType] -- Type of args - -> ExprCoFn -- HsExpr a -> HsExpr b - -> TcM ExprCoFn -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b) + -> HsWrapper -- HsExpr a -> HsExpr b + -> TcM HsWrapper -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b) wrapFunResCoercion arg_tys co_fn_res - | isIdCoercion co_fn_res = return idCoercion + | isIdHsWrapper co_fn_res = return idHsWrapper | null arg_tys = return co_fn_res | otherwise = do { arg_ids <- newSysLocalIds FSLIT("sub") arg_tys - ; return (mkCoLams arg_ids <.> co_fn_res <.> mkCoApps arg_ids) } + ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpApps arg_ids) } \end{code} @@ -761,8 +774,8 @@ tcGen :: BoxySigmaType -- expected_ty -> TcTyVarSet -- Extra tyvars that the universally -- quantified tyvars of expected_ty -- must not be unified - -> (BoxyRhoType -> TcM result) -- spec_ty - -> TcM (ExprCoFn, result) + -> ([TcTyVar] -> BoxyRhoType -> TcM result) + -> TcM (HsWrapper, result) -- The expression has type: spec_ty -> expected_ty tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type @@ -771,7 +784,7 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- mention the *instantiated* tyvar names, so that we get a -- good error message "Rigid variable 'a' is bound by (forall a. a->a)" -- Hence the tiresome but innocuous fixM - ((forall_tvs, theta, rho_ty), skol_info) <- fixM (\ ~(_, skol_info) -> + ((tvs', theta', rho'), skol_info) <- fixM (\ ~(_, skol_info) -> do { (forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty ; span <- getSrcSpanM ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) span @@ -780,13 +793,12 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall #ifdef DEBUG ; traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs, text "expected_ty" <+> ppr expected_ty, - text "inst ty" <+> ppr forall_tvs <+> ppr theta <+> ppr rho_ty, - text "free_tvs" <+> ppr free_tvs, - text "forall_tvs" <+> ppr forall_tvs]) + text "inst ty" <+> ppr tvs' <+> ppr theta' <+> ppr rho', + text "free_tvs" <+> ppr free_tvs]) #endif -- Type-check the arg and unify with poly type - ; (result, lie) <- getLIE (thing_inside rho_ty) + ; (result, lie) <- getLIE (thing_inside tvs' rho') -- Check that the "forall_tvs" havn't been constrained -- The interesting bit here is that we must include the free variables @@ -799,16 +811,16 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- Conclusion: include the free vars of the expected_ty in the -- list of "free vars" for the signature check. - ; dicts <- newDictBndrsO (SigOrigin skol_info) theta - ; inst_binds <- tcSimplifyCheck sig_msg forall_tvs dicts lie + ; dicts <- newDictBndrsO (SigOrigin skol_info) theta' + ; inst_binds <- tcSimplifyCheck sig_msg tvs' dicts lie - ; checkSigTyVarsWrt free_tvs forall_tvs + ; checkSigTyVarsWrt free_tvs tvs' ; traceTc (text "tcGen:done") ; let - -- The CoLet binds any Insts which came out of the simplification. + -- The WpLet binds any Insts which came out of the simplification. dict_ids = map instToId dicts - co_fn = mkCoTyLams forall_tvs <.> mkCoLams dict_ids <.> CoLet inst_binds + co_fn = mkWpTyLams tvs' <.> mkWpLams dict_ids <.> WpLet inst_binds ; returnM (co_fn, result) } where free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs @@ -1448,6 +1460,7 @@ unBox (TyVarTy tv) unBoxPred (ClassP cls tys) = do { tys' <- mapM unBox tys; return (ClassP cls tys') } unBoxPred (IParam ip ty) = do { ty' <- unBox ty; return (IParam ip ty') } +unBoxPred (EqPred ty1 ty2) = do { ty1' <- unBox ty1; ty2' <- unBox ty2; return (EqPred ty1' ty2') } \end{code} @@ -1477,25 +1490,28 @@ mkExpectedActualMsg act_ty exp_ty ---------------- -- If an error happens we try to figure out whether the function -- function has been given too many or too few arguments, and say so. -subCtxt mb_fun actual_res_ty expected_res_ty tidy_env - = do { exp_ty' <- zonkTcType expected_res_ty - ; act_ty' <- zonkTcType actual_res_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'' +addSubCtxt SubDone actual_res_ty expected_res_ty thing_inside + = thing_inside +addSubCtxt sub_ctxt actual_res_ty expected_res_ty thing_inside + = addErrCtxtM mk_err thing_inside + where + mk_err tidy_env + = do { exp_ty' <- zonkTcType expected_res_ty + ; act_ty' <- zonkTcType actual_res_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 + len_act_args = length act_args + len_exp_args = length exp_args - message = case mb_fun of - Just fun | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun - | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun - other -> mkExpectedActualMsg act_ty'' exp_ty'' - ; return (env2, message) } + message = case sub_ctxt of + SubFun fun | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun + | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun + other -> mkExpectedActualMsg act_ty'' exp_ty'' + ; return (env2, message) } - where wrongArgsCtxt too_many_or_few fun = ptext SLIT("Probable cause:") <+> quotes (ppr fun) <+> ptext SLIT("is applied to") <+> text too_many_or_few