Add simplifier pass after SpecConstrwip/sjakobi/T17724

Fixes #17722, #17724.

5 files changed, 120 insertions, 1 deletions

diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index b8fb162432..3f577c18c0 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -314,7 +314,9 @@ getCoreToDo dflags
                         -- reduce the possibility of shadowing
                         -- Reason: see Note [Shadowing] in SpecConstr.hs
 
-        runWhen spec_constr CoreDoSpecConstr,
+        runWhen spec_constr
+          (CoreDoPasses [ CoreDoSpecConstr
+                        , simpl_phase 0 ["post-spec-constr"] 1]),
 
         maybe_rule_check (Phase 0),
 
diff --git a/testsuite/tests/simplCore/should_compile/T17722A.hs b/testsuite/tests/simplCore/should_compile/T17722A.hs
new file mode 100644
index 0000000000..2a37163afa
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17722A.hs
@@ -0,0 +1,20 @@
+module T17722A (Validation(..)) where
+
+data Validation e a
+  = Failure e
+  | Success a
+
+instance Functor (Validation e) where
+   fmap _ (Failure e) = Failure e
+   fmap f (Success a) = Success (f a)
+
+(<.>) :: Semigroup e => Validation e (t -> a) -> Validation e t -> Validation e a
+Failure e1 <.> b = Failure $ case b of
+  Failure e2 -> e1 <> e2
+  Success _  -> e1
+Success _  <.> Failure e  = Failure  e
+Success f  <.> Success x  = Success (f x)
+
+instance Semigroup e => Applicative (Validation e) where
+  pure = Success
+  (<*>) = (<.>)
diff --git a/testsuite/tests/simplCore/should_compile/T17722B.hs b/testsuite/tests/simplCore/should_compile/T17722B.hs
new file mode 100644
index 0000000000..10f9478eb6
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17722B.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+module T17722B (setHelper) where
+
+import T17722A
+
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Sequence (Seq)
+import Data.Text (Text)
+import Data.Void (Void)
+import qualified Data.Foldable
+import qualified Data.List
+import qualified Data.Sequence
+import qualified Data.Text
+
+data Expr s a
+  = App (Expr s a) (Expr s a)
+  | List
+  | ListLit (Maybe (Expr s a)) (Seq (Expr s a))
+
+data Src
+
+type Extractor s a = Validation (ExtractErrors s a)
+
+typeError :: Expr s a -> Expr s a -> Extractor s a b
+typeError expected actual =
+    Failure . ExtractErrors . pure . TypeMismatch $ InvalidDecoder expected actual
+
+extractError :: Text -> Extractor s a b
+extractError = Failure . ExtractErrors . pure . ExtractError
+
+newtype ExtractErrors s a = ExtractErrors (NonEmpty (ExtractError s a))
+  deriving Semigroup
+
+data ExtractError s a =
+    TypeMismatch (InvalidDecoder s a)
+  | ExtractError Text
+
+data InvalidDecoder s a = InvalidDecoder (Expr s a) (Expr s a)
+
+data Decoder a = Decoder
+    (Expr Src Void -> Extractor Src Void a)
+    (Expr Src Void)
+
+setHelper :: (Eq a, Foldable t, Show a)
+          => (t a -> Int)
+          -> ([a] -> t a)
+          -> Decoder a
+          -> Decoder (t a)
+setHelper size toSet (Decoder extractIn expectedIn) = Decoder extractOut expectedOut
+  where
+    extractOut (ListLit _ es) = case traverse extractIn es of
+        Success vSeq
+            | sameSize               -> Success vSet
+            | otherwise              -> extractError err
+          where
+            vList = Data.Foldable.toList vSeq
+            vSet = toSet vList
+            sameSize = size vSet == Data.Sequence.length vSeq
+            duplicates = vList Data.List.\\ Data.Foldable.toList vSet
+            err | length duplicates == 1 =
+                     "One duplicate element in the list: "
+                     <> (Data.Text.pack $ show $ head duplicates)
+                | otherwise              = Data.Text.pack $ unwords
+                     [ show $ length duplicates
+                     , "duplicates were found in the list, including"
+                     , show $ head duplicates
+                     ]
+        Failure f -> Failure f
+    extractOut expr = typeError expectedOut expr
+
+    expectedOut = App List expectedIn
diff --git a/testsuite/tests/simplCore/should_compile/T17724.hs b/testsuite/tests/simplCore/should_compile/T17724.hs
new file mode 100644
index 0000000000..4b120160cd
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17724.hs
@@ -0,0 +1,23 @@
+{-# language ExistentialQuantification #-}
+
+-- | This code is extracted from containers' sequence-benchmarks and the gauge
+-- package.
+module T17724 where
+
+import Control.Exception (evaluate)
+
+data Benchmarkable = forall a .
+    Benchmarkable
+      { allocEnv :: Int -> IO a
+      , runRepeatedly :: a -> Int -> IO ()
+      }
+
+a, b :: Benchmarkable
+a = nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (100,2500)
+b = nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (2500,100)
+
+nf :: (a -> b) -> a -> Benchmarkable
+nf f0 x0 = Benchmarkable (const (return ())) (const (go f0 x0))
+  where go f x n
+          | n <= 0    = return ()
+          | otherwise = evaluate (f x) >> go f x (n-1)
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 7146b76e6d..8177520e3e 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -312,3 +312,5 @@ test('T17409',
      normal,
      makefile_test, ['T17409'])
 test('T17429', normal, compile, ['-dcore-lint -O2'])
+test('T17722', normal, multimod_compile, ['T17722B', '-dcore-lint -O2 -v0'])
+test('T17724', normal, compile, ['-dcore-lint -O2'])