diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-17 14:20:51 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-17 14:45:50 +0000 |
commit | 517908fce0cdae9d0ae987fa7474ee235533c77a (patch) | |
tree | 8015460ea01c3550c1b157a74038b2d08d79c68f | |
parent | 2469f854e6457d6723f12a61b88a6d9c7766ab4f (diff) | |
download | haskell-517908fce0cdae9d0ae987fa7474ee235533c77a.tar.gz |
Fix egregious bug in the new canonicalisation code for AppTy
Fixes Trac #9892.
Must form part of 7.10.1
-rw-r--r-- | compiler/typecheck/TcCanonical.hs | 12 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/T9892.hs | 16 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/all.T | 2 |
3 files changed, 25 insertions, 5 deletions
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index cc1197d748..493e742058 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -626,7 +626,9 @@ try_decompose_app :: CtEvidence -> EqRel -- so can't turn it into an application if it -- doesn't look like one already -- See Note [Canonicalising type applications] -try_decompose_app ev NomEq ty1 ty2 = try_decompose_nom_app ev ty1 ty2 +try_decompose_app ev NomEq ty1 ty2 + = try_decompose_nom_app ev ty1 ty2 + try_decompose_app ev ReprEq ty1 ty2 | ty1 `eqType` ty2 -- See Note [AppTy reflexivity check] = canEqReflexive ev ReprEq ty1 @@ -654,17 +656,17 @@ try_decompose_nom_app ev ty1 ty2 = canEqNC ev NomEq ty1 ty2 where -- do_decompose is like xCtEvidence, but recurses - -- to try_decompose_app to decompose a chain of AppTys + -- to try_decompose_nom_app to decompose a chain of AppTys do_decompose s1 t1 s2 t2 | CtDerived { ctev_loc = loc } <- ev = do { emitNewDerived loc (mkTcEqPred t1 t2) - ; try_decompose_nom_app ev s1 s2 } + ; canEqNC ev NomEq s1 s2 } | CtWanted { ctev_evar = evar, ctev_loc = loc } <- ev = do { ev_s <- newWantedEvVarNC loc (mkTcEqPred s1 s2) ; co_t <- unifyWanted loc Nominal t1 t2 ; let co = mkTcAppCo (ctEvCoercion ev_s) co_t ; setEvBind evar (EvCoercion co) - ; try_decompose_nom_app ev_s s1 s2 } + ; canEqNC ev_s NomEq s1 s2 } | CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } <- ev = do { let co = evTermCoercion ev_tm co_s = mkTcLRCo CLeft co @@ -672,7 +674,7 @@ try_decompose_nom_app ev ty1 ty2 ; evar_s <- newGivenEvVar loc (mkTcEqPred s1 s2, EvCoercion co_s) ; evar_t <- newGivenEvVar loc (mkTcEqPred t1 t2, EvCoercion co_t) ; emitWorkNC [evar_t] - ; try_decompose_nom_app evar_s s1 s2 } + ; canEqNC evar_s NomEq s1 s2 } | otherwise -- Can't happen = error "try_decompose_app" diff --git a/testsuite/tests/typecheck/should_compile/T9892.hs b/testsuite/tests/typecheck/should_compile/T9892.hs new file mode 100644 index 0000000000..adb0f29818 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T9892.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UndecidableInstances #-} + +module T9892 where + +import Control.Applicative +import Control.Category +import Prelude hiding ((.),id) + +newtype FocusingPlus w k s a = FocusingPlus { unfocusingPlus :: k (s, w) a } + +instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where + fmap f (FocusingPlus as) = FocusingPlus (fmap f as) + +instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where + pure = FocusingPlus . pure + FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka) diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 7d33ad580c..d1b379614c 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -436,3 +436,5 @@ test('T9497b', normal, compile, ['-fdefer-typed-holes -fno-warn-typed-holes']) test('T9497c', normal, compile, ['-fdefer-type-errors -fno-warn-typed-holes']) test('T7643', normal, compile, ['']) test('T9834', normal, compile, ['']) +test('T9892', normal, compile, ['']) + |