[commit: ghc] wip/impredicativity: Fix bugs on implementation of \upsilon types (864c14a)
git at git.haskell.org
git at git.haskell.org
Tue Aug 4 07:36:39 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/impredicativity
Link : http://ghc.haskell.org/trac/ghc/changeset/864c14a8c605b838c16127c5195f41860db2919f/ghc
>---------------------------------------------------------------
commit 864c14a8c605b838c16127c5195f41860db2919f
Author: Alejandro Serrano <trupill at gmail.com>
Date: Tue Aug 4 09:37:44 2015 +0200
Fix bugs on implementation of \upsilon types
>---------------------------------------------------------------
864c14a8c605b838c16127c5195f41860db2919f
compiler/typecheck/TcCanonical.hs | 18 +++++++++---------
compiler/typecheck/TcExpr.hs | 15 ++++++++-------
compiler/typecheck/TcRules.hs | 4 +++-
compiler/typecheck/TcSimplify.hs | 12 ++++++++----
compiler/typecheck/TcType.hs | 2 +-
5 files changed, 29 insertions(+), 22 deletions(-)
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 50f6cf0..59d67f8 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1744,19 +1744,19 @@ can_instance_inst ev lhs rhs
; let qvars' = map mkTyVarTy qvars
evars' = map ctev_evar new_ev_qs
; if isUpsilonTy ty
- then do { let inst = mkInstanceOfPred ty rhs
- ; new_ev_inst <- newWantedEvVarNC loc inst
- ; setWantedEvBind evar
- (mkInstanceOfInst lhs qvars' (ctEvId new_ev_inst) evars')
- ; emitWorkNC new_ev_qs
- ; traceTcS "can_instance_of/INST" (vcat [ ppr new_ev_inst, ppr new_ev_qs ])
- ; canInstanceOfNC new_ev_inst }
-- if the inner type is upsilon, generate equality
- else do { let eq = mkTcEqPredRole Nominal ty rhs
+ then do { let eq = mkTcEqPredRole Nominal ty rhs
; new_ev_eq <- newWantedEvVarNC loc eq
; setWantedEvBind evar
(mkInstanceOfInstEq lhs qvars' (ctEvCoercion new_ev_eq) evars')
; emitWorkNC new_ev_qs
; traceTcS "can_instance_of/INSTEQ" (vcat [ ppr new_ev_eq, ppr new_ev_qs ])
- ; canEqNC new_ev_eq NomEq ty rhs } }
+ ; canEqNC new_ev_eq NomEq ty rhs }
+ else do { let inst = mkInstanceOfPred ty rhs
+ ; new_ev_inst <- newWantedEvVarNC loc inst
+ ; setWantedEvBind evar
+ (mkInstanceOfInst lhs qvars' (ctEvId new_ev_inst) evars')
+ ; emitWorkNC new_ev_qs
+ ; traceTcS "can_instance_of/INST" (vcat [ ppr new_ev_inst, ppr new_ev_qs ])
+ ; canInstanceOfNC new_ev_inst } }
_ -> stopWith ev "Given/Derived instanceOf instantiation"
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 9b73562..7f7a476 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1009,19 +1009,20 @@ tc_app fun_expr args fun_ty res_ty
-- Without it, the `a` coming from `f` cannot be unified with
-- the second type variable of `error`
; if isUpsilonTy actual_res_ty
- then do { ev_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
- emitWanted AppOrigin (mkInstanceOfPred actual_res_ty res_ty)
+ then do { co_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
+ unifyType actual_res_ty res_ty
; return $ TcAppResult
(mkLHsWrapCo co_fun fun_expr) -- Instantiated function
args1 -- Arguments
- -- Coercion to expected result type
- (mkWpInstanceOf ev_res) }
- else do { co_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
- unifyType actual_res_ty res_ty
+ (coToHsWrapper co_res) } -- Coercion to expected result type
+ else do { ev_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
+ emitWanted AppOrigin (mkInstanceOfPred actual_res_ty res_ty)
; return $ TcAppResult
(mkLHsWrapCo co_fun fun_expr) -- Instantiated function
args1 -- Arguments
- (coToHsWrapper co_res) } } -- Coercion to expected result type
+ -- Coercion to expected result type
+ (mkWpInstanceOf ev_res) } }
+
mk_app_msg :: Outputable a => a -> SDoc
mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
index f439675..aafb520 100644
--- a/compiler/typecheck/TcRules.hs
+++ b/compiler/typecheck/TcRules.hs
@@ -73,8 +73,10 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
tcExtendIdEnv id_bndrs $
do { -- See Note [Solve order for RULES]
((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
+ ; (lhs_inst_simple, _) <- runTcS (instantiateCts (wc_simple lhs_wanted))
+ ; let lhs_inst = lhs_wanted { wc_simple = lhs_inst_simple }
; (rhs', rhs_wanted) <- captureConstraints (tcPolyMonoExpr rhs rule_ty)
- ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }
+ ; return (lhs', lhs_inst, rhs', rhs_wanted, rule_ty) }
; (lhs_evs, other_lhs_wanted) <- simplifyRule (snd $ unLoc name)
(bndr_wanted `andWC` lhs_wanted)
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index f080c09..e95c9f7 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -9,7 +9,8 @@ module TcSimplify(
solveWantedsTcM,
-- For Rules we need these three
- solveWanteds, runTcS, instantiateWC
+ solveWanteds, runTcS, approximateWC,
+ instantiateCts
) where
#include "HsVersions.h"
@@ -1327,7 +1328,7 @@ defaultTyVar the_tv
| otherwise = return the_tv -- The common case
approximateWC :: WantedConstraints -> TcS Cts
-approximateWC = fmap andManyCts . mapM instantiateWC . bagToList . approximateWC_
+approximateWC = instantiateCts . approximateWC_
approximateWC_ :: WantedConstraints -> Cts
-- Postcondition: Wanted or Derived Cts
@@ -1362,8 +1363,11 @@ approximateWC_ wc
do_bag :: (a -> Bag c) -> Bag a -> Bag c
do_bag f = foldrBag (unionBags.f) emptyBag
-instantiateWC :: Ct -> TcS Cts
-instantiateWC ct
+instantiateCts :: Cts -> TcS Cts
+instantiateCts = fmap andManyCts . mapM instantiateCt . bagToList
+
+instantiateCt :: Ct -> TcS Cts
+instantiateCt ct
| isWantedCt ct, InstanceOfPred lhs rhs <- classifyPredType (ctPred ct)
= do { let loc = ctLoc ct
; (_qvars, q, ty) <- deeplySplitInst lhs
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index b27e4f6..425d0f5 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -1429,7 +1429,7 @@ isUpsilonTy ty
| isSigmaTy ty = False
| Just v <- tcGetTyVar_maybe ty = not (isImmutableTyVar v)
| Just (tc, _) <- tcSplitTyConApp_maybe ty = isFamilyTyCon tc
- | otherwise = True
+ | otherwise = False
isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
isUnitTy, isCharTy, isAnyTy :: Type -> Bool
More information about the ghc-commits
mailing list