[Git][ghc/ghc][wip/T23864] testsuite: Add regression test for #23864

[Zubin (@wz1000)]

Zubin pushed to branch wip/T23864 at Glasgow Haskell Compiler / GHC


Commits:
950e23a6 by Zubin Duggal at 2023-08-28T15:15:34+05:30
testsuite: Add regression test for #23864

Simon says this was fixed by

commit 59202c800f2c97c16906120ab2561f6e1556e4af
Author: Sebastian Graf <sebastian.graf at 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.

- - - - -


2 changed files:

- + testsuite/tests/simplCore/should_compile/T23864.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
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 at 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


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/950e23a6299d72b85a5472299f5efee1efdb7a0e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/950e23a6299d72b85a5472299f5efee1efdb7a0e
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230828/498b2029/attachment-0001.html>