[commit: ghc] master: Fix #11232. (cab1316)

[git at git.haskell.org]

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

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

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

commit cab131624ad0cdd54e2f3a70f93c1bd574ccf102
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Thu Dec 17 12:18:47 2015 +0100

    Fix #11232.
    
    I somehow forgot to propagate roles into UnivCos. Very
    simple fix, happily.
    
    Test Plan: simplCore/should_compile/T11232
    
    Reviewers: bgamari, austin, simonpj
    
    Reviewed By: simonpj
    
    Subscribers: simonpj, thomie
    
    Differential Revision: https://phabricator.haskell.org/D1645
    
    GHC Trac Issues: #11232


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

cab131624ad0cdd54e2f3a70f93c1bd574ccf102
 compiler/types/OptCoercion.hs                      | 37 ++++++++++++----------
 testsuite/tests/simplCore/should_compile/T11232.hs | 15 +++++++++
 testsuite/tests/simplCore/should_compile/all.T     |  1 +
 3 files changed, 36 insertions(+), 17 deletions(-)

diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs
index f68bc8c..436b16a 100644
--- a/compiler/types/OptCoercion.hs
+++ b/compiler/types/OptCoercion.hs
@@ -87,21 +87,24 @@ optCoercion :: TCvSubst -> Coercion -> NormalCo
 --   *and* optimises it to reduce its size
 optCoercion env co
   | opt_NoOptCoercion = substCo env co
-  | debugIsOn         = let out_co = opt_co1 lc False co
-                            Pair in_ty1  in_ty2  = coercionKind co
-                            Pair out_ty1 out_ty2 = coercionKind out_co
-                        in
-                        ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&
-                                 substTy env in_ty2 `eqType` out_ty2
-                               , text "optCoercion changed types!"
-                              $$ hang (text "in_co:") 2 (ppr co)
-                              $$ hang (text "in_ty1:") 2 (ppr in_ty1)
-                              $$ hang (text "in_ty2:") 2 (ppr in_ty2)
-                              $$ hang (text "out_co:") 2 (ppr out_co)
-                              $$ hang (text "out_ty1:") 2 (ppr out_ty1)
-                              $$ hang (text "out_ty2:") 2 (ppr out_ty2)
-                              $$ hang (text "subst:") 2 (ppr env) )
-                        out_co
+  | debugIsOn
+  = let out_co = opt_co1 lc False co
+        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co
+        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
+    in
+    ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&
+             substTy env in_ty2 `eqType` out_ty2 &&
+             in_role == out_role
+           , text "optCoercion changed types!"
+             $$ hang (text "in_co:") 2 (ppr co)
+             $$ hang (text "in_ty1:") 2 (ppr in_ty1)
+             $$ hang (text "in_ty2:") 2 (ppr in_ty2)
+             $$ hang (text "out_co:") 2 (ppr out_co)
+             $$ hang (text "out_ty1:") 2 (ppr out_ty1)
+             $$ hang (text "out_ty2:") 2 (ppr out_ty2)
+             $$ hang (text "subst:") 2 (ppr env) )
+    out_co
+
   | otherwise         = opt_co1 lc False co
   where
     lc = mkSubstLiftingContext env
@@ -230,9 +233,9 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos)
                                  cos)
       -- Note that the_co does *not* have sym pushed into it
 
-opt_co4 env sym _ r (UnivCo prov _r t1 t2)
+opt_co4 env sym rep r (UnivCo prov _r t1 t2)
   = ASSERT( r == _r )
-    opt_univ env sym prov r t1 t2
+    opt_univ env sym prov (chooseRole rep r) t1 t2
 
 opt_co4 env sym rep r (TransCo co1 co2)
                       -- sym (g `o` h) = sym h `o` sym g
diff --git a/testsuite/tests/simplCore/should_compile/T11232.hs b/testsuite/tests/simplCore/should_compile/T11232.hs
new file mode 100644
index 0000000..5b98d39
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T11232.hs
@@ -0,0 +1,15 @@
+module T11232 where
+
+import Control.Monad
+import Data.Data
+
+mkMp :: ( MonadPlus m
+        , Typeable a
+        , Typeable b
+        )
+     => (b -> m b)
+     -> a
+     -> m a
+mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext)))
+
+newtype M m x = M { unM :: x -> m x }
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index f9388c9..2ea15f6 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -228,3 +228,4 @@ test('T11155',
      normal,
      run_command,
      ['$MAKE -s --no-print-directory T11155'])
+test('T11232', normal, compile, ['-O2'])