[commit: ghc] master: Fix #11401. (35d37ff)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/35d37ff8a0bb9f64f347c8e4b6a24d49fd08c9dc/ghc

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

commit 35d37ff8a0bb9f64f347c8e4b6a24d49fd08c9dc
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Mon Feb 22 22:15:44 2016 -0500

    Fix #11401.
    
    This commit teaches shortCutReduction about Derived constraints.
    
    [skip ci]


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

35d37ff8a0bb9f64f347c8e4b6a24d49fd08c9dc
 compiler/typecheck/TcInteract.hs                   | 40 +++++++++-------------
 testsuite/tests/typecheck/should_compile/T11401.hs | 33 ++++++++++++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 3 files changed, 50 insertions(+), 24 deletions(-)

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 90f7243..a0654d2 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -1527,47 +1527,39 @@ shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
                   -> TyCon -> [TcType] -> TcS (StopOrContinue Ct)
 -- See Note [Top-level reductions for type functions]
 shortCutReduction old_ev fsk ax_co fam_tc tc_args
-  | isGiven old_ev
-  = ASSERT( ctEvEqRel old_ev == NomEq )
+  = ASSERT( ctEvEqRel old_ev == NomEq)
     do { (xis, cos) <- flattenManyNom old_ev tc_args
                -- ax_co :: F args ~ G tc_args
                -- cos   :: xis ~ tc_args
                -- old_ev :: F args ~ fsk
                -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
 
-       ; new_ev <- newGivenEvVar deeper_loc
+       ; new_ev <- case ctEvFlavour old_ev of
+           Given -> newGivenEvVar deeper_loc
                          ( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
                          , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos
                                         `mkTcTransCo` mkTcSymCo ax_co
                                         `mkTcTransCo` ctEvCoercion old_ev) )
 
-       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk }
-       ; updWorkListTcS (extendWorkListFunEq new_ct)
-       ; stopWith old_ev "Fun/Top (given, shortcut)" }
+           Derived -> newDerivedNC deeper_loc $
+                      mkPrimEqPred (mkTyConApp fam_tc xis)
+                                   (mkTyVarTy fsk)
 
-  | otherwise
-  = ASSERT( not (isDerived old_ev) )   -- Caller ensures this
-    ASSERT( ctEvEqRel old_ev == NomEq )
-    do { (xis, cos) <- flattenManyNom old_ev tc_args
-               -- ax_co :: F args ~ G tc_args
-               -- cos   :: xis ~ tc_args
-               -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
-               -- new_ev :: G xis ~ fsk
-               -- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev
-
-       ; (new_ev, new_co) <- newWantedEq deeper_loc Nominal
-                                     (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
-       ; setWantedEq (ctev_dest old_ev)
-                     (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos)
-                            `mkTcTransCo` new_co)
+           Wanted ->
+             do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal
+                                        (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
+                ; setWantedEq (ctev_dest old_ev) $
+                     ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal
+                                                      fam_tc cos)
+                           `mkTcTransCo` new_co
+                ; return new_ev }
 
        ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
                                 , cc_tyargs = xis, cc_fsk = fsk }
        ; updWorkListTcS (extendWorkListFunEq new_ct)
-       ; stopWith old_ev "Fun/Top (wanted, shortcut)" }
+       ; stopWith old_ev "Fun/Top (shortcut)" }
   where
-    loc = ctEvLoc old_ev
-    deeper_loc = bumpCtLocDepth loc
+    deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
 
 dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
 -- (dischargeFmv x fmv co ty)
diff --git a/testsuite/tests/typecheck/should_compile/T11401.hs b/testsuite/tests/typecheck/should_compile/T11401.hs
new file mode 100644
index 0000000..5235aaf
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11401.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+module T11401 where
+
+newtype Value a = Value a
+newtype CodeGen r a = CodeGen a
+
+bind :: CodeGen r a -> (a -> CodeGen r b) -> CodeGen r b
+bind (CodeGen a) k = k a
+
+class
+   (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) =>
+       CallArgs f g r where
+   type CalledFunction g :: *
+   type CallerResult g :: *
+   type CallerFunction f r :: *
+   call :: f -> g
+
+instance CallArgs (IO a) (CodeGen r (Value a)) r where
+   type CalledFunction (CodeGen r (Value a)) = IO a
+   type CallerResult (CodeGen r (Value a)) = r
+   type CallerFunction (IO a) r = CodeGen r (Value a)
+   call = undefined
+
+instance CallArgs b b' r => CallArgs (a -> b) (Value a -> b') r where
+   type CalledFunction (Value a -> b') = a -> CalledFunction b'
+   type CallerResult (Value a -> b') = CallerResult b'
+   type CallerFunction (a -> b) r = Value a -> CallerFunction b r
+   call = undefined
+
+test :: IO a -> (a -> IO ()) -> CodeGen () (Value ())
+test start stop  =  bind (call start) (call stop)
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index ca8cd0a..8974153 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -507,3 +507,4 @@ test('T11524', normal, compile, [''])
 test('T11552', normal, compile, [''])
 test('T11246', normal, compile, [''])
 test('T11608', normal, compile, [''])
+test('T11401', normal, compile, [''])