diff options
Diffstat (limited to 'compiler/GHC/Tc/Utils')
| -rw-r--r-- | compiler/GHC/Tc/Utils/TcMType.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Unify.hs | 19 |
2 files changed, 18 insertions, 14 deletions
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index ed9ee9cc44..1e82be0f0e 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -137,7 +137,6 @@ import GHC.Types.Basic ( TypeOrKind(..) ) import Control.Monad import GHC.Data.Maybe -import Control.Arrow ( second ) import qualified Data.Semigroup as Semi {- @@ -2516,13 +2515,11 @@ zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act ; (env2, exp') <- zonkTidyTcType env1 exp ; return ( env2, orig { uo_actual = act' , uo_expected = exp' }) } -zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, m_ty2') <- case m_ty2 of - Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 - Nothing -> return (env1, Nothing) - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } +zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) = do { (env1, p1') <- zonkTidyTcType env p1 ; (env2, p2') <- zonkTidyTcType env1 p2 diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 121ebfbe7e..eee4e1844c 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -22,7 +22,7 @@ module GHC.Tc.Utils.Unify ( buildImplicationFor, buildTvImplication, emitResidualTvConstraint, -- Various unifications - unifyType, unifyKind, + unifyType, unifyKind, unifyExpectedType, uType, promoteTcType, swapOverTyVars, canSolveByUnification, @@ -543,11 +543,18 @@ tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc -- It means we don't need to pass in a CtOrigin tcWrapResultMono rn_expr expr act_ty res_ty = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr ) - do { co <- case res_ty of - Infer inf_res -> fillInferResult act_ty inf_res - Check exp_ty -> unifyType (Just (ppr rn_expr)) act_ty exp_ty + do { co <- unifyExpectedType rn_expr act_ty res_ty ; return (mkHsWrapCo co expr) } +unifyExpectedType :: HsExpr GhcRn + -> TcRhoType -- Actual -- a rho-type not a sigma-type + -> ExpRhoType -- Expected + -> TcM TcCoercionN +unifyExpectedType rn_expr act_ty exp_ty + = case exp_ty of + Infer inf_res -> fillInferResult act_ty inf_res + Check exp_ty -> unifyType (Just (ppr rn_expr)) act_ty exp_ty + ------------------------ tcSubTypePat :: CtOrigin -> UserTypeCtxt -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper @@ -1249,7 +1256,7 @@ uType t_or_k origin orig_ty1 orig_ty2 = do { let ty1 = coercionType co1 ty2 = coercionType co2 ; kco <- uType KindLevel - (KindEqOrigin orig_ty1 (Just orig_ty2) origin + (KindEqOrigin orig_ty1 orig_ty2 origin (Just t_or_k)) ty1 ty2 ; return $ mkProofIrrelCo Nominal kco co1 co2 } @@ -1463,7 +1470,7 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2 ; defer } ty1 = mkTyVarTy tv1 - kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) + kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k) defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 |