[commit: ghc] master: Fix egregious bug in the new canonicalisation code for AppTy (517908f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/517908fce0cdae9d0ae987fa7474ee235533c77a/ghc

>---------------------------------------------------------------

commit 517908fce0cdae9d0ae987fa7474ee235533c77a
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Dec 17 14:20:51 2014 +0000

    Fix egregious bug in the new canonicalisation code for AppTy
    
    Fixes Trac #9892.
    
    Must form part of 7.10.1


>---------------------------------------------------------------

517908fce0cdae9d0ae987fa7474ee235533c77a
 compiler/typecheck/TcCanonical.hs                 | 12 +++++++-----
 testsuite/tests/typecheck/should_compile/T9892.hs | 16 ++++++++++++++++
 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 cc1197d..493e742 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 0000000..adb0f29
--- /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 7d33ad5..d1b3796 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, [''])
+