From 1957eda1b25735b143899add93a4cd4f0af3b2ea Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Mon, 23 Jan 2023 20:26:59 -0500
Subject: [PATCH] Restore Compose's Read/Show behavior to match Read1/Show1
instances
Fixes #22816.
---
libraries/base/Data/Functor/Compose.hs | 27 ++++++++++++++++------
libraries/base/tests/T22816.hs | 31 ++++++++++++++++++++++++++
libraries/base/tests/T22816.stdout | 2 ++
libraries/base/tests/all.T | 1 +
4 files changed, 54 insertions(+), 7 deletions(-)
create mode 100644 libraries/base/tests/T22816.hs
create mode 100644 libraries/base/tests/T22816.stdout
diff --git a/libraries/base/Data/Functor/Compose.hs b/libraries/base/Data/Functor/Compose.hs
index 49955402a6d..53bb53c2342 100644
--- a/libraries/base/Data/Functor/Compose.hs
+++ b/libraries/base/Data/Functor/Compose.hs
@@ -33,7 +33,7 @@ import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
-import Text.Read ()
+import Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)
infixr 9 `Compose`
@@ -55,9 +55,14 @@ deriving instance Eq (f (g a)) => Eq (Compose f g a)
-- | @since 4.18.0.0
deriving instance Ord (f (g a)) => Ord (Compose f g a)
-- | @since 4.18.0.0
-deriving instance Read (f (g a)) => Read (Compose f g a)
+instance Read (f (g a)) => Read (Compose f g a) where
+ readPrec = liftReadPrecCompose readPrec
+
+ readListPrec = readListPrecDefault
+ readList = readListDefault
-- | @since 4.18.0.0
-deriving instance Show (f (g a)) => Show (Compose f g a)
+instance Show (f (g a)) => Show (Compose f g a) where
+ showsPrec = liftShowsPrecCompose showsPrec
-- Instances of lifted Prelude classes
@@ -72,8 +77,8 @@ instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
-- | @since 4.9.0.0
instance (Read1 f, Read1 g) => Read1 (Compose f g) where
- liftReadPrec rp rl = readData $
- readUnaryWith (liftReadPrec rp' rl') "Compose" Compose
+ liftReadPrec rp rl =
+ liftReadPrecCompose (liftReadPrec rp' rl')
where
rp' = liftReadPrec rp rl
rl' = liftReadListPrec rp rl
@@ -83,12 +88,20 @@ instance (Read1 f, Read1 g) => Read1 (Compose f g) where
-- | @since 4.9.0.0
instance (Show1 f, Show1 g) => Show1 (Compose f g) where
- liftShowsPrec sp sl d (Compose x) =
- showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
+ liftShowsPrec sp sl =
+ liftShowsPrecCompose (liftShowsPrec sp' sl')
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
+-- The workhorse for Compose's Read and Read1 instances.
+liftReadPrecCompose :: ReadPrec (f (g a)) -> ReadPrec (Compose f g a)
+liftReadPrecCompose rp = readData $ readUnaryWith rp "Compose" Compose
+
+-- The workhorse for Compose's Show and Show1 instances.
+liftShowsPrecCompose :: (Int -> f (g a) -> ShowS) -> Int -> Compose f g a -> ShowS
+liftShowsPrecCompose sp d (Compose x) = showsUnaryWith sp "Compose" d x
+
-- Functor instances
-- | @since 4.9.0.0
diff --git a/libraries/base/tests/T22816.hs b/libraries/base/tests/T22816.hs
new file mode 100644
index 00000000000..0105a18c9d9
--- /dev/null
+++ b/libraries/base/tests/T22816.hs
@@ -0,0 +1,31 @@
+module Main (main) where
+
+import Data.Functor.Classes
+import Data.Functor.Compose
+import Text.ParserCombinators.ReadP as P
+import Text.ParserCombinators.ReadPrec (ReadPrec, lift, minPrec, readPrec_to_S)
+
+readEither' :: ReadPrec a -> String -> Either String a
+readEither' rp s =
+ case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
+ [x] -> Right x
+ [] -> Left "read1: no parse"
+ _ -> Left "read1: ambiguous parse"
+ where
+ read' =
+ do x <- rp
+ lift P.skipSpaces
+ return x
+
+-- | Like 'read', but tailored to 'Read1'.
+read1 :: (Read1 f, Read a) => String -> f a
+read1 s = either errorWithoutStackTrace id (readEither' readPrec1 s)
+
+exRead, exRead1 :: Compose Maybe Maybe Int
+exRead = read "Compose Nothing"
+exRead1 = read1 "Compose Nothing"
+
+main :: IO ()
+main = do
+ putStrLn $ showsPrec 0 exRead ""
+ putStrLn $ showsPrec1 0 exRead1 ""
diff --git a/libraries/base/tests/T22816.stdout b/libraries/base/tests/T22816.stdout
new file mode 100644
index 00000000000..1957c7edf8d
--- /dev/null
+++ b/libraries/base/tests/T22816.stdout
@@ -0,0 +1,2 @@
+Compose Nothing
+Compose Nothing
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 2b253ceca8c..73e6059d7ca 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -286,6 +286,7 @@ test('T18642',
test('T19288', exit_code(1), compile_and_run, [''])
test('T19719', normal, compile_and_run, [''])
test('T20107', extra_run_opts('+RTS -M50M'), compile_and_run, ['-package bytestring'])
+test('T22816', normal, compile_and_run, [''])
test('trace', normal, compile_and_run, [''])
test('listThreads', js_broken(22261), compile_and_run, [''])
test('inits1tails1', normal, compile_and_run, [''])
--
GitLab