ref: 25f0c79b84be2d043e14867e38ba919eb348296c
parent: 924f18d2d6cc10dbfa191a710e274bb6660ea50a
author: Lennart Augustsson <lennart@augustsson.net>
date: Fri Sep 20 10:01:19 EDT 2024
Add Data.Functor.Classes
--- a/Makefile
+++ b/Makefile
@@ -198,7 +198,7 @@
MCABALBIN=$(MCABAL)/bin
MDIST=dist-mcabal
BASE=base-$(VERSION)
-BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.ST Control.Monad.Zip Data.Array Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Float Data.FloatW Data.Floating Data.Foldable Data.Fractional Data.Function Data.Functor Data.Functor.Const Data.Functor.Identity Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Compress System.Directory System.Environment System.Exit System.IO System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.Read Text.Read.Lex Text.Read.Numeric Text.Show TimeCompat Unsafe.Coerce
+BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.ST Control.Monad.Zip Data.Array Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Float Data.FloatW Data.Floating Data.Foldable Data.Fractional Data.Function Data.Functor Data.Functor.Classes Data.Functor.Const Data.Functor.Identity Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Compress System.Directory System.Environment System.Exit System.IO System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.Read Text.Read.Lex Text.Read.Numeric Text.Show TimeCompat Unsafe.Coerce
$(MCABALBIN)/mhs: bin/mhs
@mkdir -p $(MCABALBIN)
--- a/lib/AllOfLib.hs
+++ b/lib/AllOfLib.hs
@@ -31,6 +31,7 @@
import Data.Fractional
import Data.Function
import Data.Functor
+import Data.Functor.Classes
import Data.Functor.Const
import Data.Functor.Identity
import Data.IOArray
--- /dev/null
+++ b/lib/Data/Functor/Classes.hs
@@ -1,0 +1,588 @@
+module Data.Functor.Classes (
+ -- * Liftings of Prelude classes
+ -- ** For unary constructors
+ Eq1(..), eq1,
+ Ord1(..), compare1,
+ Read1(..), -- readsPrec1, readPrec1,
+-- liftReadListDefault, liftReadListPrecDefault,
+ Show1(..), showsPrec1,
+ -- ** For binary constructors
+ Eq2(..), eq2,
+ Ord2(..), compare2,
+ Read2(..), -- readsPrec2, readPrec2,
+-- liftReadList2Default, liftReadListPrec2Default,
+ Show2(..), showsPrec2,
+ -- * Helper functions
+-- readsData, readData,
+-- readsUnaryWith, readUnaryWith,
+-- readsBinaryWith, readBinaryWith,
+ showsUnaryWith,
+ showsBinaryWith,
+ ) where
+
+import Control.Applicative (Alternative((<|>)), Const(Const))
+import Data.Functor.Identity (Identity(Identity))
+import Data.Proxy (Proxy(Proxy))
+import Data.List.NonEmpty (NonEmpty(..))
+--import Data.Ord (Down(Down))
+import Data.Complex (Complex((:+)))
+import Data.Tuple (Solo (..))
+
+{-+import GHC.Read (expectP, list, paren)
+import Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec)
+import Text.Read (Read(..), parens, prec, step)
+import Text.Read.Lex (Lexeme(..))
+-}
+import Text.Read
+import Text.Show (showListWith)
+
+class Eq1 f where
+ liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool
+
+eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool
+eq1 = liftEq (==)
+
+class (Eq1 f) => Ord1 f where
+ liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering
+
+compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering
+compare1 = liftCompare compare
+
+class Read1 f where
+{-+ liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
+ liftReadsPrec rp rl = readPrec_to_S $
+ liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))
+
+ liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
+ liftReadList rp rl = readPrec_to_S
+ (list $ liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0
+
+ liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
+ liftReadPrec rp rl = readS_to_Prec $
+ liftReadsPrec (readPrec_to_S rp) (readPrec_to_S rl 0)
+
+ liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
+ liftReadListPrec rp rl = readS_to_Prec $ \_ ->
+ liftReadList (readPrec_to_S rp) (readPrec_to_S rl 0)
+
+readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)
+readsPrec1 = liftReadsPrec readsPrec readList
+
+readPrec1 :: (Read1 f, Read a) => ReadPrec (f a)
+readPrec1 = liftReadPrec readPrec readListPrec
+
+liftReadListDefault :: Read1 f => (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
+liftReadListDefault rp rl = readPrec_to_S
+ (liftReadListPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0
+
+liftReadListPrecDefault :: Read1 f => ReadPrec a -> ReadPrec [a]
+ -> ReadPrec [f a]
+liftReadListPrecDefault rp rl = list (liftReadPrec rp rl)
+-}
+
+class Show1 f where
+ liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ Int -> f a -> ShowS
+ liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ [f a] -> ShowS
+ liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)
+
+showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS
+showsPrec1 = liftShowsPrec showsPrec showList
+
+class Eq2 f where
+ liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
+
+eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool
+eq2 = liftEq2 (==) (==)
+
+class (Eq2 f) => Ord2 f where
+ liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->
+ f a c -> f b d -> Ordering
+
+compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering
+compare2 = liftCompare2 compare compare
+
+class Read2 f where
+{-+ liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->
+ (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)
+ liftReadsPrec2 rp1 rl1 rp2 rl2 = readPrec_to_S $
+ liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))
+ (readS_to_Prec rp2) (readS_to_Prec (const rl2))
+
+ liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->
+ (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
+ liftReadList2 rp1 rl1 rp2 rl2 = readPrec_to_S
+ (list $ liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))
+ (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0
+
+ liftReadPrec2 :: ReadPrec a -> ReadPrec [a] ->
+ ReadPrec b -> ReadPrec [b] -> ReadPrec (f a b)
+ liftReadPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $
+ liftReadsPrec2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)
+ (readPrec_to_S rp2) (readPrec_to_S rl2 0)
+
+ liftReadListPrec2 :: ReadPrec a -> ReadPrec [a] ->
+ ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]
+ liftReadListPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $ \_ ->
+ liftReadList2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)
+ (readPrec_to_S rp2) (readPrec_to_S rl2 0)
+
+readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)
+readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList
+
+readPrec2 :: (Read2 f, Read a, Read b) => ReadPrec (f a b)
+readPrec2 = liftReadPrec2 readPrec readListPrec readPrec readListPrec
+
+liftReadList2Default :: Read2 f => (Int -> ReadS a) -> ReadS [a] ->
+ (Int -> ReadS b) -> ReadS [b] ->ReadS [f a b]
+liftReadList2Default rp1 rl1 rp2 rl2 = readPrec_to_S
+ (liftReadListPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))
+ (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0
+
+liftReadListPrec2Default :: Read2 f => ReadPrec a -> ReadPrec [a] ->
+ ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]
+liftReadListPrec2Default rp1 rl1 rp2 rl2 = list (liftReadPrec2 rp1 rl1 rp2 rl2)
+-}
+
+class Show2 f where
+ liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS
+
+ liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS
+ liftShowList2 sp1 sl1 sp2 sl2 =
+ showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)
+
+showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS
+showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList
+
+instance Eq1 Maybe where
+ liftEq _ Nothing Nothing = True
+ liftEq _ Nothing (Just _) = False
+ liftEq _ (Just _) Nothing = False
+ liftEq eq (Just x) (Just y) = eq x y
+
+instance Ord1 Maybe where
+ liftCompare _ Nothing Nothing = EQ
+ liftCompare _ Nothing (Just _) = LT
+ liftCompare _ (Just _) Nothing = GT
+ liftCompare comp (Just x) (Just y) = comp x y
+
+{-+instance Read1 Maybe where
+ liftReadPrec rp _ =
+ parens (expectP (Ident "Nothing") *> pure Nothing)
+ <|>
+ readData (readUnaryWith rp "Just" Just)
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance Show1 Maybe where
+ liftShowsPrec _ _ _ Nothing = showString "Nothing"
+ liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x
+
+instance Eq1 [] where
+ liftEq _ [] [] = True
+ liftEq _ [] (_:_) = False
+ liftEq _ (_:_) [] = False
+ liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys
+
+instance Ord1 [] where
+ liftCompare _ [] [] = EQ
+ liftCompare _ [] (_:_) = LT
+ liftCompare _ (_:_) [] = GT
+ liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys
+
+{-+instance Read1 [] where
+ liftReadPrec _ rl = rl
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance Show1 [] where
+ liftShowsPrec _ sl _ = sl
+
+instance Eq1 NonEmpty where
+ liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs
+
+instance Ord1 NonEmpty where
+ liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs
+
+{-+instance Read1 NonEmpty where
+ liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do
+ (a, s'') <- rdP 6 s'
+ (":|", s''') <- lex s''+ (as, s'''') <- rdL s'''
+ return (a :| as, s'''')) s
+-}
+
+instance Show1 NonEmpty where
+ liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $
+ shwP 6 a . showString " :| " . shwL as
+
+instance Eq2 (,) where
+ liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2
+
+instance Ord2 (,) where
+ liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =
+ comp1 x1 x2 `mappend` comp2 y1 y2
+
+{-+instance Read2 (,) where
+ liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do
+ x <- rp1
+ expectP (Punc ",")
+ y <- rp2
+ return (x,y)
+
+ liftReadListPrec2 = liftReadListPrec2Default
+ liftReadList2 = liftReadList2Default
+-}
+
+instance Show2 (,) where
+ liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
+ showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'+
+instance Eq1 Solo where
+ liftEq eq (MkSolo a) (MkSolo b) = a `eq` b
+
+instance (Eq a) => Eq1 ((,) a) where
+ liftEq = liftEq2 (==)
+
+instance Ord1 Solo where
+ liftCompare cmp (MkSolo a) (MkSolo b) = cmp a b
+
+instance (Ord a) => Ord1 ((,) a) where
+ liftCompare = liftCompare2 compare
+
+{-+instance Read1 Solo where
+ liftReadPrec rp _ = readData (readUnaryWith rp "Solo" Solo)
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+instance (Read a) => Read1 ((,) a) where
+ liftReadPrec = liftReadPrec2 readPrec readListPrec
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance Show1 Solo where
+ liftShowsPrec sp _ d (MkSolo x) = showsUnaryWith sp "MkSolo" d x
+
+instance (Show a) => Show1 ((,) a) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance Eq a => Eq2 ((,,) a) where
+ liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) =
+ u1 == v1 &&
+ e1 x1 x2 && e2 y1 y2
+
+instance Ord a => Ord2 ((,,) a) where
+ liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) =
+ compare u1 v1 `mappend`
+ comp1 x1 x2 `mappend` comp2 y1 y2
+
+{-+instance Read a => Read2 ((,,) a) where
+ liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do
+ x1 <- readPrec
+ expectP (Punc ",")
+ y1 <- rp1
+ expectP (Punc ",")
+ y2 <- rp2
+ return (x1,y1,y2)
+
+ liftReadListPrec2 = liftReadListPrec2Default
+ liftReadList2 = liftReadList2Default
+-}
+
+instance Show a => Show2 ((,,) a) where
+ liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2)
+ = showChar '(' . showsPrec 0 x1+ . showChar ',' . sp1 0 y1
+ . showChar ',' . sp2 0 y2
+ . showChar ')'
+
+instance (Eq a, Eq b) => Eq1 ((,,) a b) where
+ liftEq = liftEq2 (==)
+
+instance (Ord a, Ord b) => Ord1 ((,,) a b) where
+ liftCompare = liftCompare2 compare
+
+{-+instance (Read a, Read b) => Read1 ((,,) a b) where
+ liftReadPrec = liftReadPrec2 readPrec readListPrec
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance (Show a, Show b) => Show1 ((,,) a b) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+{-+instance (Eq a, Eq b) => Eq2 ((,,,) a b) where
+ liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
+ u1 == v1 &&
+ u2 == v2 &&
+ e1 x1 x2 && e2 y1 y2
+
+instance (Ord a, Ord b) => Ord2 ((,,,) a b) where
+ liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
+ compare u1 v1 `mappend`
+ compare u2 v2 `mappend`
+ comp1 x1 x2 `mappend` comp2 y1 y2
+
+instance (Read a, Read b) => Read2 ((,,,) a b) where
+ liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do
+ x1 <- readPrec
+ expectP (Punc ",")
+ x2 <- readPrec
+ expectP (Punc ",")
+ y1 <- rp1
+ expectP (Punc ",")
+ y2 <- rp2
+ return (x1,x2,y1,y2)
+
+ liftReadListPrec2 = liftReadListPrec2Default
+ liftReadList2 = liftReadList2Default
+
+instance (Show a, Show b) => Show2 ((,,,) a b) where
+ liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2)
+ = showChar '(' . showsPrec 0 x1+ . showChar ',' . showsPrec 0 x2
+ . showChar ',' . sp1 0 y1
+ . showChar ',' . sp2 0 y2
+ . showChar ')'
+
+instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where
+ liftEq = liftEq2 (==)
+
+instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where
+ liftCompare = liftCompare2 compare
+
+instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where
+ liftReadPrec = liftReadPrec2 readPrec readListPrec
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance (Generic1 f, Eq1 (Rep1 f)) => Eq1 (Generically1 f) where
+ liftEq :: (a1 -> a2 -> Bool) -> (Generically1 f a1 -> Generically1 f a2 -> Bool)
+ liftEq (===) (Generically1 as1) (Generically1 as2) = liftEq (===) (from1 as1) (from1 as2)
+
+instance (Generic1 f, Ord1 (Rep1 f)) => Ord1 (Generically1 f) where
+ liftCompare :: (a1 -> a2 -> Ordering) -> (Generically1 f a1 -> Generically1 f a2 -> Ordering)
+ liftCompare cmp (Generically1 as1) (Generically1 as2) = liftCompare cmp (from1 as1) (from1 as2)
+-}
+
+instance Eq2 Either where
+ liftEq2 e1 _ (Left x) (Left y) = e1 x y
+ liftEq2 _ _ (Left _) (Right _) = False
+ liftEq2 _ _ (Right _) (Left _) = False
+ liftEq2 _ e2 (Right x) (Right y) = e2 x y
+
+instance Ord2 Either where
+ liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y
+ liftCompare2 _ _ (Left _) (Right _) = LT
+ liftCompare2 _ _ (Right _) (Left _) = GT
+ liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y
+
+{-+instance Read2 Either where
+ liftReadPrec2 rp1 _ rp2 _ = readData $
+ readUnaryWith rp1 "Left" Left <|>
+ readUnaryWith rp2 "Right" Right
+
+ liftReadListPrec2 = liftReadListPrec2Default
+ liftReadList2 = liftReadList2Default
+-}
+
+instance Show2 Either where
+ liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x
+ liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x
+
+instance (Eq a) => Eq1 (Either a) where
+ liftEq = liftEq2 (==)
+
+instance (Ord a) => Ord1 (Either a) where
+ liftCompare = liftCompare2 compare
+
+{-+instance (Read a) => Read1 (Either a) where
+ liftReadPrec = liftReadPrec2 readPrec readListPrec
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance (Show a) => Show1 (Either a) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance Eq1 Identity where
+ liftEq eq (Identity x) (Identity y) = eq x y
+
+instance Ord1 Identity where
+ liftCompare comp (Identity x) (Identity y) = comp x y
+
+{-+instance Read1 Identity where
+ liftReadPrec rp _ = readData $
+ readUnaryWith rp "Identity" Identity
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance Show1 Identity where
+ liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x
+
+instance Eq2 Const where
+ liftEq2 eq _ (Const x) (Const y) = eq x y
+
+instance Ord2 Const where
+ liftCompare2 comp _ (Const x) (Const y) = comp x y
+
+{-+instance Read2 Const where
+ liftReadPrec2 rp _ _ _ = readData $
+ readUnaryWith rp "Const" Const
+
+ liftReadListPrec2 = liftReadListPrec2Default
+ liftReadList2 = liftReadList2Default
+-}
+
+instance Show2 Const where
+ liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x
+
+instance (Eq a) => Eq1 (Const a) where
+ liftEq = liftEq2 (==)
+
+instance (Ord a) => Ord1 (Const a) where
+ liftCompare = liftCompare2 compare
+
+{-+instance (Read a) => Read1 (Const a) where
+ liftReadPrec = liftReadPrec2 readPrec readListPrec
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance (Show a) => Show1 (Const a) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance Eq1 Proxy where
+ liftEq _ _ _ = True
+
+instance Ord1 Proxy where
+ liftCompare _ _ _ = EQ
+
+instance Show1 Proxy where
+ liftShowsPrec _ _ _ _ = showString "Proxy"
+
+{-+instance Read1 Proxy where
+ liftReadPrec _ _ = parens (expectP (Ident "Proxy") *> pure Proxy)
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+{-+instance Eq1 Down where
+ liftEq eq (Down x) (Down y) = eq x y
+
+instance Ord1 Down where
+ liftCompare comp (Down x) (Down y) = case comp x y of
+ LT -> GT
+ EQ -> EQ
+ GT -> LT
+
+{-+instance Read1 Down where
+ liftReadsPrec rp _ = readsData $
+ readsUnaryWith rp "Down" Down
+-}
+
+instance Show1 Down where
+ liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x
+-}
+
+instance Eq1 Complex where
+ liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v
+
+{-+instance Read1 Complex where
+ liftReadPrec rp _ = parens $ prec complexPrec $ do
+ x <- step rp
+ expectP (Symbol ":+")
+ y <- step rp
+ return (x :+ y)
+ where
+ complexPrec = 6
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance Show1 Complex where
+ liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $
+ sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y
+ where
+ complexPrec = 6
+
+{-+readsData :: (String -> ReadS a) -> Int -> ReadS a
+readsData reader d =
+ readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]
+
+readData :: ReadPrec a -> ReadPrec a
+readData reader = parens $ prec 10 reader
+
+readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
+readsUnaryWith rp name cons kw s =
+ [(cons x,t) | kw == name, (x,t) <- rp 11 s]
+
+readUnaryWith :: ReadPrec a -> String -> (a -> t) -> ReadPrec t
+readUnaryWith rp name cons = do
+ expectP $ Ident name
+ x <- step rp
+ return $ cons x
+
+readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->
+ String -> (a -> b -> t) -> String -> ReadS t
+readsBinaryWith rp1 rp2 name cons kw s =
+ [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]
+
+readBinaryWith :: ReadPrec a -> ReadPrec b ->
+ String -> (a -> b -> t) -> ReadPrec t
+readBinaryWith rp1 rp2 name cons = do
+ expectP $ Ident name
+ x <- step rp1
+ y <- step rp2
+ return $ cons x y
+-}
+
+showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
+showsUnaryWith sp name d x = showParen (d > 10) $
+ showString name . showChar ' ' . sp 11 x
+
+showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->
+ String -> Int -> a -> b -> ShowS
+showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $
+ showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y
--- a/lib/Data/Ord.hs
+++ b/lib/Data/Ord.hs
@@ -50,3 +50,64 @@
comparing :: (Ord b) => (a -> b) -> a -> a -> Ordering
comparing f x y = compare (f x) (f y)
+
+{-+newtype Down a = Down
+ { getDown :: a -- ^ @since 4.14.0.0+ }
+ deriving
+ ( Eq -- ^ @since 4.6.0.0
+ , Num -- ^ @since 4.11.0.0
+ , Semigroup -- ^ @since 4.11.0.0
+ , Monoid -- ^ @since 4.11.0.0
+ , Bits -- ^ @since 4.14.0.0
+ , FiniteBits -- ^ @since 4.14.0.0
+ , Floating -- ^ @since 4.14.0.0
+ , Fractional -- ^ @since 4.14.0.0
+ , Ix -- ^ @since 4.14.0.0
+ , Real -- ^ @since 4.14.0.0
+ , RealFrac -- ^ @since 4.14.0.0
+ , RealFloat -- ^ @since 4.14.0.0
+ , Storable -- ^ @since 4.14.0.0
+ )
+
+-- | This instance would be equivalent to the derived instances of the
+-- 'Down' newtype if the 'getDown' field were removed
+--
+-- @since 4.7.0.0
+instance (Read a) => Read (Down a) where
+ readsPrec d = readParen (d > 10) $ \ r ->
+ [(Down x,t) | ("Down",s) <- lex r, (x,t) <- readsPrec 11 s]+
+-- | This instance would be equivalent to the derived instances of the
+-- 'Down' newtype if the 'getDown' field were removed
+--
+-- @since 4.7.0.0
+instance (Show a) => Show (Down a) where
+ showsPrec d (Down x) = showParen (d > 10) $
+ showString "Down " . showsPrec 11 x
+
+-- | @since 4.6.0.0
+instance Ord a => Ord (Down a) where
+ compare (Down x) (Down y) = y `compare` x
+
+-- | Swaps @'minBound'@ and @'maxBound'@ of the underlying type.
+--
+-- @since 4.14.0.0
+instance Bounded a => Bounded (Down a) where
+ minBound = Down maxBound
+ maxBound = Down minBound
+
+-- | @since 4.11.0.0
+instance Functor Down where
+ fmap = coerce
+
+-- | @since 4.11.0.0
+instance Applicative Down where
+ pure = Down
+ (<*>) = coerce
+
+-- | @since 4.11.0.0
+instance Monad Down where
+ Down a >>= k = k a
+-}
--
⑨