Commit 1957eda1 authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot
Browse files

Restore Compose's Read/Show behavior to match Read1/Show1 instances

Fixes #22816.
parent e5383a29
Pipeline #62068 passed with stages
in 209 minutes and 10 seconds
......@@ -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
......
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 ""
Compose Nothing
Compose Nothing
......@@ -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, [''])
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment