Fix a buglet in Simplify.simplCast

This bug, revealed by #18347, is just a missing update to
sc_hole_ty in simplCast.  I'd missed a code path when I
made the recentchanges in

    commit 6d49d5be904c0c01788fa7aae1b112d5b4dfaf1c
    Author: Simon Peyton Jones <simonpj@microsoft.com>
    Date:   Thu May 21 12:53:35 2020 +0100

    Implement cast worker/wrapper properly

The fix is very easy.

Two other minor changes

* Tidy up in SimpleOpt.simple_opt_expr. In fact I think this is an
  outright bug, introduced in the fix to #18112: we were simplifying
  the same coercion twice *with the same substitution*, which is just
  wrong.  It'd be a hard bug to trigger, so I just fixed it; less code
  too.

* Better debug printing of ApplyToVal

5 files changed, 32 insertions, 13 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 81cf962d91..dba4362a81 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -1456,7 +1456,8 @@ simplCast env body co0 cont0
           = {-#SCC "addCoerce-pushCoValArg" #-}
             do { tail' <- addCoerceM m_co2 tail
                ; if isReflCo co1
-                 then return (cont { sc_cont = tail' })
+                 then return (cont { sc_cont = tail'
+                                   , sc_hole_ty = coercionLKind co })
                       -- Avoid simplifying if possible;
                       -- See Note [Avoiding exponential behaviour]
                  else do
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 5f2db4508d..eca8f0a474 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -221,9 +221,10 @@ instance Outputable SimplCont where
   ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont
   ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })
     = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
-  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
-    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)
-                                        $$ ppr cont
+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })
+    = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty)
+          2 (pprParendExpr arg))
+      $$ ppr cont
   ppr (StrictBind { sc_bndr = b, sc_cont = cont })
     = (text "StrictBind" <+> ppr b) $$ ppr cont
   ppr (StrictArg { sc_fun = ai, sc_cont = cont })
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 87ad9e69c5..9901f752b1 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -213,6 +213,7 @@ simple_opt_expr env expr
     in_scope     = substInScope subst
     in_scope_env = (in_scope, simpleUnfoldingFun)
 
+    ---------------
     go (Var v)
        | Just clo <- lookupVarEnv (soe_inl env) v
        = simple_opt_clo env clo
@@ -221,17 +222,10 @@ simple_opt_expr env expr
 
     go (App e1 e2)      = simple_app env e1 [(env,e2)]
     go (Type ty)        = Type     (substTy subst ty)
-    go (Coercion co)    = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co)
+    go (Coercion co)    = Coercion (go_co co)
     go (Lit lit)        = Lit lit
     go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
-    go (Cast e co)      = case go e of
-                            -- flatten nested casts before calling the coercion optimizer;
-                            -- see #18112 (note that mkCast handles dropping Refl coercions)
-                            Cast e' co' -> mkCast e' (opt_co (mkTransCo co' co))
-                            e'          -> mkCast e' (opt_co co)
-                          where
-                            opt_co = optCoercion (soe_dflags env) (getTCvSubst subst)
-
+    go (Cast e co)      = mk_cast (go e) (go_co co)
     go (Let bind body)  = case simple_opt_bind env bind NotTopLevel of
                              (env', Nothing)   -> simple_opt_expr env' body
                              (env', Just bind) -> Let bind (simple_opt_expr env' body)
@@ -267,6 +261,9 @@ simple_opt_expr env expr
         (env', b') = subst_opt_bndr env b
 
     ----------------------
+    go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co
+
+    ----------------------
     go_alt env (con, bndrs, rhs)
       = (con, bndrs', simple_opt_expr env' rhs)
       where
@@ -285,6 +282,15 @@ simple_opt_expr env expr
          bs = reverse bs'
          e' = simple_opt_expr env e
 
+mk_cast :: CoreExpr -> CoercionR -> CoreExpr
+-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check.
+-- mkCast doesn't do that because the Simplifier does (in simplCast)
+-- But in SimpleOpt it's nice to kill those nested casts (#18112)
+mk_cast (Cast e co1) co2        = mk_cast e (co1 `mkTransCo` co2)
+mk_cast (Tick t e)   co         = Tick t (mk_cast e co)
+mk_cast e co | isReflexiveCo co = e
+             | otherwise        = Cast e co
+
 ----------------------
 -- simple_app collects arguments for beta reduction
 simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
diff --git a/testsuite/tests/simplCore/should_compile/T18347.hs b/testsuite/tests/simplCore/should_compile/T18347.hs
new file mode 100644
index 0000000000..50ecf461fa
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18347.hs
@@ -0,0 +1,10 @@
+module T18347 (function) where
+
+import Data.Coerce
+
+newtype All = All Bool
+
+data Encoding = Encoding (Char -> Bool)
+
+function :: Encoding -> Char -> All
+function enc v = coerce (case enc of Encoding x -> x) v
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 4c301cd6f2..ea77a92c36 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -328,3 +328,4 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com
 # Cast WW
 test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
 test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
+test('T18347', normal, compile, ['-dcore-lint -O'])