[commit: ghc] ghc-7.10: Fix #10079 by recurring after flattening exposes a TyConApp. (dfb6b9f)

[git at git.haskell.org]

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

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/dfb6b9f8290ebed55636074cea53f583d3ce1134/ghc

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

commit dfb6b9f8290ebed55636074cea53f583d3ce1134
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Feb 11 13:06:15 2015 -0500

    Fix #10079 by recurring after flattening exposes a TyConApp.
    
    Previously, try_decompose_nom_app was smart enough to recur if
    flattening exposed a TyConApp, but try_decompose_repr_app was
    not. Now, if neither type in try_decompose_repr_app is an AppTy,
    recur.
    
    Seems all straightforward enough to avoid a Note.
    
    (cherry picked from commit befe2d7c8902096dd184ebca3f7f135ee5f479e8)


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

dfb6b9f8290ebed55636074cea53f583d3ce1134
 compiler/typecheck/TcCanonical.hs                    | 13 +++++++++++--
 .../tests/indexed-types/should_compile/T10079.hs     | 20 ++++++++++++++++++++
 testsuite/tests/indexed-types/should_compile/all.T   |  1 +
 3 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 75263fa..8df7ee1 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -642,9 +642,18 @@ try_decompose_repr_app ev ty1 ty2
   | ty1 `eqType` ty2   -- See Note [AppTy reflexivity check]
   = canEqReflexive ev ReprEq ty1
 
-  | otherwise
+  | AppTy {} <- ty1
+  = canEqFailure ev ReprEq ty1 ty2
+
+  | AppTy {} <- ty2
   = canEqFailure ev ReprEq ty1 ty2
 
+  | otherwise  -- flattening in can_eq_wanted_app exposed some TyConApps!
+  = ASSERT2( isJust (tcSplitTyConApp_maybe ty1) || isJust (tcSplitTyConApp_maybe ty2)
+            , ppr ty1 $$ ppr ty2 )  -- If this assertion fails, we may fall
+                                    -- into an infinite loop
+    canEqNC ev ReprEq ty1 ty2
+
 ---------
 try_decompose_nom_app :: CtEvidence
                       -> TcType -> TcType -> TcS (StopOrContinue Ct)
@@ -667,7 +676,7 @@ try_decompose_nom_app ev ty1 ty2
                 -- is good: See Note [Canonicalising type applications]
    = ASSERT2( isJust (tcSplitTyConApp_maybe ty1) || isJust (tcSplitTyConApp_maybe ty2)
             , ppr ty1 $$ ppr ty2 )  -- If this assertion fails, we may fall
-                                    -- into an inifinite loop (Trac #9971)
+                                    -- into an infinite loop (Trac #9971)
      canEqNC ev NomEq ty1 ty2
    where
      -- do_decompose is like xCtEvidence, but recurses
diff --git a/testsuite/tests/indexed-types/should_compile/T10079.hs b/testsuite/tests/indexed-types/should_compile/T10079.hs
new file mode 100644
index 0000000..6651a74
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T10079.hs
@@ -0,0 +1,20 @@
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleContexts #-}
+module T10079 where
+
+import Control.Applicative
+import Data.Coerce
+
+broken :: Bizarre (->) w => w a b t -> ()
+broken = getConst #. bazaar (Const #. const ())
+
+class Profunctor p where
+  (#.) :: Coercible c b => (b -> c) -> p a b -> p a c
+
+instance Profunctor (->) where
+  (#.) = (.)
+
+class Bizarre p w | w -> p where 
+  bazaar :: Applicative f => p a (f b) -> w a b t -> f t
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 9f76c7d..f4df933 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -251,3 +251,4 @@ test('T9747', normal, compile, [''])
 test('T9582', normal, compile, [''])
 test('T9090', normal, compile, [''])
 test('T10020', normal, compile, [''])
+test('T10079', normal, compile, [''])