diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2023-01-23 20:26:59 -0500 |
---|---|---|
committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2023-01-23 20:27:01 -0500 |
commit | fb996f99f483753976fd55d0a25823090b8830ec (patch) | |
tree | ba07fcbc249c2e7f0770b106d61d89452250abf1 | |
parent | 82884ce063180a39afed163590738f7095394583 (diff) | |
download | haskell-wip/T22816.tar.gz |
Restore Compose's Read/Show behavior to match Read1/Show1 instanceswip/T22816
Fixes #22816.
-rw-r--r-- | libraries/base/Data/Functor/Compose.hs | 27 | ||||
-rw-r--r-- | libraries/base/tests/T22816.hs | 31 | ||||
-rw-r--r-- | libraries/base/tests/T22816.stdout | 2 | ||||
-rw-r--r-- | libraries/base/tests/all.T | 1 |
4 files changed, 54 insertions, 7 deletions
diff --git a/libraries/base/Data/Functor/Compose.hs b/libraries/base/Data/Functor/Compose.hs index 49955402a6..53bb53c234 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 0000000000..0105a18c9d --- /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 0000000000..1957c7edf8 --- /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 2b253ceca8..73e6059d7c 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, ['']) |