[Git][ghc/ghc][master] Restore Compose's Read/Show behavior to match Read1/Show1 instances

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
1957eda1 by Ryan Scott at 2023-01-24T20:03:01-05:00
Restore Compose's Read/Show behavior to match Read1/Show1 instances

Fixes #22816.

- - - - -


4 changed files:

- libraries/base/Data/Functor/Compose.hs
- + libraries/base/tests/T22816.hs
- + libraries/base/tests/T22816.stdout
- libraries/base/tests/all.T


Changes:

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


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


=====================================
libraries/base/tests/T22816.stdout
=====================================
@@ -0,0 +1,2 @@
+Compose Nothing
+Compose Nothing


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1957eda1b25735b143899add93a4cd4f0af3b2ea

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1957eda1b25735b143899add93a4cd4f0af3b2ea
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/20230124/82349d2a/attachment-0001.html>