From b6903f4d677673b144ec1b7864970961a182715e Mon Sep 17 00:00:00 2001
From: Zubin Duggal <zubin.duggal@gmail.com>
Date: Mon, 28 Aug 2023 15:05:47 +0530
Subject: [PATCH] testsuite: Add regression test for #23864
Simon says this was fixed by
commit 59202c800f2c97c16906120ab2561f6e1556e4af
Author: Sebastian Graf <sebastian.graf@kit.edu>
Date: Fri Mar 31 17:35:22 2023 +0200
CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead
We eliminate EmptyCase by way of `coreToStg (Case e _ _ []) = coreToStg e` now.
The main reason is that it plays far better in conjunction with eta expansion
(as we aim to do for arguments in CorePrep, #23083), because we can discard
any arguments, `(case e of {}) eta == case e of {}`, whereas in `(e |> co) eta`
it's impossible to discard the argument.
---
.../tests/simplCore/should_compile/T23864.hs | 71 +++++++++++++++++++
.../tests/simplCore/should_compile/all.T | 1 +
2 files changed, 72 insertions(+)
create mode 100644 testsuite/tests/simplCore/should_compile/T23864.hs
diff --git a/testsuite/tests/simplCore/should_compile/T23864.hs b/testsuite/tests/simplCore/should_compile/T23864.hs
new file mode 100644
index 000000000000..e51bac7eb2ca
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23864.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+module M where
+
+import Control.Monad.State
+import GHC.Hs
+import GHC.Types.SrcLoc
+import Type.Reflection
+import Data.Data (Data, gmapM)
+
+type HsModule1 = HsModule GhcPs
+
+type GenericM m = forall a. Data a => a -> m a
+
+everywhereM :: forall m. Monad m => GenericM m -> GenericM m
+everywhereM f = go
+ where
+ go :: GenericM m
+ go x = do
+ x' <- gmapM go x
+ f x'
+
+-- | 'State' with comments.
+type WithComments = State [LEpaComment]
+
+relocateComments :: HsModule1 -> [LEpaComment] -> HsModule1
+relocateComments = evalState . relocateCommentsBeforeTopLevelDecls
+
+-- | This function locates comments located before top-level declarations.
+relocateCommentsBeforeTopLevelDecls :: HsModule1 -> WithComments HsModule1
+relocateCommentsBeforeTopLevelDecls = everywhereM (applyM f)
+ where
+ f epa = insertCommentsByPos (const True) insertPriorComments epa
+
+-- | This function applies the given function to all 'EpAnn's.
+applyM ::
+ forall a. Typeable a
+ => (forall b. EpAnn b -> WithComments (EpAnn b))
+ -> (a -> WithComments a)
+applyM f
+ | App g _ <- typeRep @a
+ , Just HRefl <- eqTypeRep g (typeRep @EpAnn) = f
+ | otherwise = pure
+
+insertCommentsByPos ::
+ (RealSrcSpan -> Bool)
+ -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
+ -> EpAnn a
+ -> WithComments (EpAnn a)
+insertCommentsByPos cond = insertComments (cond . anchor . getLoc)
+
+insertComments ::
+ (LEpaComment -> Bool)
+ -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
+ -> EpAnn a
+ -> WithComments (EpAnn a)
+insertComments cond inserter epa@EpAnn {..} = do
+ coms <- drainComments cond
+ pure $ epa {comments = inserter comments coms}
+insertComments _ _ EpAnnNotUsed = pure EpAnnNotUsed
+
+insertPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
+insertPriorComments (EpaComments prior) cs =
+ EpaComments (prior ++ cs)
+insertPriorComments (EpaCommentsBalanced prior following) cs =
+ EpaCommentsBalanced (prior ++ cs) following
+
+drainComments :: (LEpaComment -> Bool) -> WithComments [LEpaComment]
+drainComments cond = undefined
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 0794d3ed430b..cf59d5e6f89a 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -496,3 +496,4 @@ test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -
# The -ddump-simpl of T22404 should have no let-bindings
test('T22404', [only_ways(['optasm']), check_errmsg(r'let') ], compile, ['-ddump-simpl -dsuppress-uniques'])
+test('T23864', normal, compile, ['-O -dcore-lint -package ghc -Wno-gadt-mono-local-binds'])
--
GitLab