switch liftings of Prelude classes to use explicit dictionaries
authorRoss Paterson <ross@soi.city.ac.uk>
Wed, 25 Mar 2015 19:23:09 +0000 (19:23 +0000)
committerRoss Paterson <ross@soi.city.ac.uk>
Wed, 25 Mar 2015 19:23:09 +0000 (19:23 +0000)
15 files changed:
Control/Applicative/Backwards.hs
Control/Applicative/Lift.hs
Control/Monad/Trans/Error.hs
Control/Monad/Trans/Except.hs
Control/Monad/Trans/Identity.hs
Control/Monad/Trans/List.hs
Control/Monad/Trans/Maybe.hs
Control/Monad/Trans/Writer/Lazy.hs
Control/Monad/Trans/Writer/Strict.hs
Data/Functor/Classes.hs
Data/Functor/Compose.hs
Data/Functor/Constant.hs
Data/Functor/Product.hs
Data/Functor/Reverse.hs
Data/Functor/Sum.hs

index d70cf38..820abf4 100644 (file)
@@ -31,22 +31,24 @@ import Data.Traversable
 -- actions in the reverse order.
 newtype Backwards f a = Backwards { forwards :: f a }
 
-instance (Eq1 f, Eq a) => Eq (Backwards f a) where
-    Backwards x == Backwards y = eq1 x y
+instance (Eq1 f) => Eq1 (Backwards f) where
+    eqWith eq (Backwards x) (Backwards y) = eqWith eq x y
 
-instance (Ord1 f, Ord a) => Ord (Backwards f a) where
-    compare (Backwards x) (Backwards y) = compare1 x y
+instance (Ord1 f) => Ord1 (Backwards f) where
+    compareWith comp (Backwards x) (Backwards y) = compareWith comp x y
 
-instance (Read1 f, Read a) => Read (Backwards f a) where
-    readsPrec = readsData $ readsUnary1 "Backwards" Backwards
+instance (Read1 f) => Read1 (Backwards f) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith rp) "Backwards" Backwards
 
-instance (Show1 f, Show a) => Show (Backwards f a) where
-    showsPrec d (Backwards x) = showsUnary1 "Backwards" d x
+instance (Show1 f) => Show1 (Backwards f) where
+    showsPrecWith sp d (Backwards x) =
+        showsUnaryWith (showsPrecWith sp) "Backwards" d x
 
-instance (Eq1 f) => Eq1 (Backwards f) where eq1 = (==)
-instance (Ord1 f) => Ord1 (Backwards f) where compare1 = compare
-instance (Read1 f) => Read1 (Backwards f) where readsPrec1 = readsPrec
-instance (Show1 f) => Show1 (Backwards f) where showsPrec1 = showsPrec
+instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1
 
 -- | Derived instance.
 instance (Functor f) => Functor (Backwards f) where
index 64f1da7..42c9b73 100644 (file)
@@ -38,29 +38,32 @@ import Data.Traversable (Traversable(traverse))
 -- applicative functor.
 data Lift f a = Pure a | Other (f a)
 
-instance (Eq1 f, Eq a) => Eq (Lift f a) where
-    Pure x1 == Pure x2 = x1 == x2
-    Other y1 == Other y2 = eq1 y1 y2
-    _ == _ = False
-
-instance (Ord1 f, Ord a) => Ord (Lift f a) where
-    compare (Pure x1) (Pure x2) = compare x1 x2
-    compare (Pure _) (Other _) = LT
-    compare (Other _) (Pure _) = GT
-    compare (Other y1) (Other y2) = compare1 y1 y2
-
-instance (Read1 f, Read a) => Read (Lift f a) where
-    readsPrec = readsData $
-        readsUnary "Pure" Pure `mappend` readsUnary1 "Other" Other
-
-instance (Show1 f, Show a) => Show (Lift f a) where
-    showsPrec d (Pure x) = showsUnary "Pure" d x
-    showsPrec d (Other y) = showsUnary1 "Other" d y
-
-instance (Eq1 f) => Eq1 (Lift f) where eq1 = (==)
-instance (Ord1 f) => Ord1 (Lift f) where compare1 = compare
-instance (Read1 f) => Read1 (Lift f) where readsPrec1 = readsPrec
-instance (Show1 f) => Show1 (Lift f) where showsPrec1 = showsPrec
+instance (Eq1 f) => Eq1 (Lift f) where
+    eqWith eq (Pure x1) (Pure x2) = eq x1 x2
+    eqWith eq (Pure _) (Other _) = False
+    eqWith eq (Other _) (Pure _) = False
+    eqWith eq (Other y1) (Other y2) = eqWith eq y1 y2
+
+instance (Ord1 f) => Ord1 (Lift f) where
+    compareWith comp (Pure x1) (Pure x2) = comp x1 x2
+    compareWith comp (Pure _) (Other _) = LT
+    compareWith comp (Other _) (Pure _) = GT
+    compareWith comp (Other y1) (Other y2) = compareWith comp y1 y2
+
+instance (Read1 f) => Read1 (Lift f) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith rp "Pure" Pure `mappend`
+        readsUnaryWith (readsPrecWith rp) "Other" Other
+
+instance (Show1 f) => Show1 (Lift f) where
+    showsPrecWith sp d (Pure x) = showsUnaryWith sp "Pure" d x
+    showsPrecWith sp d (Other y) =
+        showsUnaryWith (showsPrecWith sp) "Other" d y
+
+instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1
 
 instance (Functor f) => Functor (Lift f) where
     fmap f (Pure x) = Pure (f x)
index 4ef66a4..cdda5b1 100644 (file)
@@ -157,22 +157,26 @@ instance (Error e) => MonadPlus (Either e) where
 -- sequences two subcomputations, failing on the first error.
 newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
 
-instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where
-    ErrorT x == ErrorT y = eq1 x y
+instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where
+    eqWith eq (ErrorT x) (ErrorT y) = eqWith (eqWith eq) x y
 
-instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where
-    compare (ErrorT x) (ErrorT y) = compare1 x y
+instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where
+    compareWith comp (ErrorT x) (ErrorT y) = compareWith (compareWith comp) x y
 
-instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where
-    readsPrec = readsData $ readsUnary1 "ErrorT" ErrorT
+instance (Read e, Read1 m) => Read1 (ErrorT e m) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith (readsPrecWith rp)) "ErrorT" ErrorT
 
-instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where
-    showsPrec d (ErrorT m) = showsUnary1 "ErrorT" d m
+instance (Show e, Show1 m) => Show1 (ErrorT e m) where
+    showsPrecWith sp d (ErrorT m) =
+        showsUnaryWith (showsPrecWith (showsPrecWith sp)) "ErrorT" d m
 
-instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where eq1 = (==)
-instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where compare1 = compare
-instance (Read e, Read1 m) => Read1 (ErrorT e m) where readsPrec1 = readsPrec
-instance (Show e, Show1 m) => Show1 (ErrorT e m) where showsPrec1 = showsPrec
+instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1
+instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1
+instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where
+    readsPrec = readsPrec1
+instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where
+    showsPrec = showsPrec1
 
 -- | Map the unwrapped computation using the given function.
 --
index 0283dba..92d7dcf 100644 (file)
@@ -102,22 +102,27 @@ withExcept = withExceptT
 -- first exception.
 newtype ExceptT e m a = ExceptT (m (Either e a))
 
-instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where
-    ExceptT x == ExceptT y = eq1 x y
+instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where
+    eqWith eq (ExceptT x) (ExceptT y) = eqWith (eqWith eq) x y
 
-instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where
-    compare (ExceptT x) (ExceptT y) = compare1 x y
+instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where
+    compareWith comp (ExceptT x) (ExceptT y) =
+        compareWith (compareWith comp) x y
 
-instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where
-    readsPrec = readsData $ readsUnary1 "ExceptT" ExceptT
+instance (Read e, Read1 m) => Read1 (ExceptT e m) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith (readsPrecWith rp)) "ExceptT" ExceptT
 
-instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where
-    showsPrec d (ExceptT m) = showsUnary1 "ExceptT" d m
+instance (Show e, Show1 m) => Show1 (ExceptT e m) where
+    showsPrecWith sp d (ExceptT m) =
+        showsUnaryWith (showsPrecWith (showsPrecWith sp)) "ExceptT" d m
 
-instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where eq1 = (==)
-instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where compare1 = compare
-instance (Read e, Read1 m) => Read1 (ExceptT e m) where readsPrec1 = readsPrec
-instance (Show e, Show1 m) => Show1 (ExceptT e m) where showsPrec1 = showsPrec
+instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1
+instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1
+instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where
+    readsPrec = readsPrec1
+instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where
+    showsPrec = showsPrec1
 
 -- | The inverse of 'ExceptT'.
 runExceptT :: ExceptT e m a -> m (Either e a)
index 1fa4d6c..6639aa3 100644 (file)
@@ -40,22 +40,24 @@ import Data.Traversable (Traversable(traverse))
 -- | The trivial monad transformer, which maps a monad to an equivalent monad.
 newtype IdentityT f a = IdentityT { runIdentityT :: f a }
 
-instance (Eq1 f, Eq a) => Eq (IdentityT f a) where
-    IdentityT x == IdentityT y = eq1 x y
+instance (Eq1 f) => Eq1 (IdentityT f) where
+    eqWith eq (IdentityT x) (IdentityT y) = eqWith eq x y
 
-instance (Ord1 f, Ord a) => Ord (IdentityT f a) where
-    compare (IdentityT x) (IdentityT y) = compare1 x y
+instance (Ord1 f) => Ord1 (IdentityT f) where
+    compareWith comp (IdentityT x) (IdentityT y) = compareWith comp x y
 
-instance (Read1 f, Read a) => Read (IdentityT f a) where
-    readsPrec = readsData $ readsUnary1 "IdentityT" IdentityT
+instance (Read1 f) => Read1 (IdentityT f) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith rp) "IdentityT" IdentityT
 
-instance (Show1 f, Show a) => Show (IdentityT f a) where
-    showsPrec d (IdentityT m) = showsUnary1 "IdentityT" d m
+instance (Show1 f) => Show1 (IdentityT f) where
+    showsPrecWith sp d (IdentityT m) =
+        showsUnaryWith (showsPrecWith sp) "IdentityT" d m
 
-instance (Eq1 f) => Eq1 (IdentityT f) where eq1 = (==)
-instance (Ord1 f) => Ord1 (IdentityT f) where compare1 = compare
-instance (Read1 f) => Read1 (IdentityT f) where readsPrec1 = readsPrec
-instance (Show1 f) => Show1 (IdentityT f) where showsPrec1 = showsPrec
+instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1
+instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1
 
 instance (Functor m) => Functor (IdentityT m) where
     fmap f = mapIdentityT (fmap f)
index 5804f5f..09f9f47 100644 (file)
@@ -41,22 +41,24 @@ import Data.Traversable (Traversable(traverse))
 -- /Note:/ this does not yield a monad unless the argument monad is commutative.
 newtype ListT m a = ListT { runListT :: m [a] }
 
-instance (Eq1 m, Eq a) => Eq (ListT m a) where
-    ListT x == ListT y = eq1 x y
+instance (Eq1 m) => Eq1 (ListT m) where
+    eqWith eq (ListT x) (ListT y) = eqWith (eqWith eq) x y
 
-instance (Ord1 m, Ord a) => Ord (ListT m a) where
-    compare (ListT x) (ListT y) = compare1 x y
+instance (Ord1 m) => Ord1 (ListT m) where
+    compareWith comp (ListT x) (ListT y) = compareWith (compareWith comp) x y
 
-instance (Read1 m, Read a) => Read (ListT m a) where
-    readsPrec = readsData $ readsUnary1 "ListT" ListT
+instance (Read1 m) => Read1 (ListT m) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith (readsPrecWith rp)) "ListT" ListT
 
-instance (Show1 m, Show a) => Show (ListT m a) where
-    showsPrec d (ListT m) = showsUnary1 "ListT" d m
+instance (Show1 m) => Show1 (ListT m) where
+    showsPrecWith sp d (ListT m) =
+        showsUnaryWith (showsPrecWith (showsPrecWith sp)) "ListT" d m
 
-instance (Eq1 m) => Eq1 (ListT m) where eq1 = (==)
-instance (Ord1 m) => Ord1 (ListT m) where compare1 = compare
-instance (Read1 m) => Read1 (ListT m) where readsPrec1 = readsPrec
-instance (Show1 m) => Show1 (ListT m) where showsPrec1 = showsPrec
+instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1
+instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1
+instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1
+instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1
 
 -- | Map between 'ListT' computations.
 --
index 2fc160c..e014ac4 100644 (file)
@@ -60,22 +60,24 @@ import Data.Traversable (Traversable(traverse))
 -- computation does.
 newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
 
-instance (Eq1 m, Eq a) => Eq (MaybeT m a) where
-    MaybeT x == MaybeT y = eq1 x y
+instance (Eq1 m) => Eq1 (MaybeT m) where
+    eqWith eq (MaybeT x) (MaybeT y) = eqWith (eqWith eq) x y
 
-instance (Ord1 m, Ord a) => Ord (MaybeT m a) where
-    compare (MaybeT x) (MaybeT y) = compare1 x y
+instance (Ord1 m) => Ord1 (MaybeT m) where
+    compareWith comp (MaybeT x) (MaybeT y) = compareWith (compareWith comp) x y
 
-instance (Read1 m, Read a) => Read (MaybeT m a) where
-    readsPrec = readsData $ readsUnary1 "MaybeT" MaybeT
+instance (Read1 m) => Read1 (MaybeT m) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith (readsPrecWith rp)) "MaybeT" MaybeT
 
-instance (Show1 m, Show a) => Show (MaybeT m a) where
-    showsPrec d (MaybeT m) = showsUnary1 "MaybeT" d m
+instance (Show1 m) => Show1 (MaybeT m) where
+    showsPrecWith sp d (MaybeT m) =
+        showsUnaryWith (showsPrecWith (showsPrecWith sp)) "MaybeT" d m
 
-instance (Eq1 m) => Eq1 (MaybeT m) where eq1 = (==)
-instance (Ord1 m) => Ord1 (MaybeT m) where compare1 = compare
-instance (Read1 m) => Read1 (MaybeT m) where readsPrec1 = readsPrec
-instance (Show1 m) => Show1 (MaybeT m) where showsPrec1 = showsPrec
+instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1
+instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1
+instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1
+instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1
 
 -- | Transform the computation inside a @MaybeT@.
 --
index 853c2d3..4d1fb74 100644 (file)
@@ -100,22 +100,28 @@ mapWriter f = mapWriterT (Identity . f . runIdentity)
 -- combines the outputs of the subcomputations using 'mappend'.
 newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
 
-instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where
-    WriterT x == WriterT y = eq1 x y
+instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where
+    eqWith eq (WriterT m1) (WriterT m2) = eqWith (eqWith2 eq (==)) m1 m2
 
-instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where
-    compare (WriterT x) (WriterT y) = compare1 x y
+instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where
+    compareWith comp (WriterT m1) (WriterT m2) =
+        compareWith (compareWith2 comp compare) m1 m2
 
-instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where
-    readsPrec = readsData $ readsUnary1 "WriterT" WriterT
+instance (Read w, Read1 m) => Read1 (WriterT w m) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith (readsPrecWith2 rp readsPrec))
+            "WriterT" WriterT
 
-instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where
-    showsPrec d (WriterT m) = showsUnary1 "WriterT" d m
+instance (Show w, Show1 m) => Show1 (WriterT w m) where
+    showsPrecWith sp d (WriterT m) =
+        showsUnaryWith (showsPrecWith (showsPrecWith2 sp showsPrec)) "WriterT" d m
 
-instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where eq1 = (==)
-instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where compare1 = compare
-instance (Read w, Read1 m) => Read1 (WriterT w m) where readsPrec1 = readsPrec
-instance (Show w, Show1 m) => Show1 (WriterT w m) where showsPrec1 = showsPrec
+instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1
+instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1
+instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where
+    readsPrec = readsPrec1
+instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where
+    showsPrec = showsPrec1
 
 -- | Extract the output from a writer computation.
 --
index 92320fa..148661d 100644 (file)
@@ -103,22 +103,28 @@ mapWriter f = mapWriterT (Identity . f . runIdentity)
 -- combines the outputs of the subcomputations using 'mappend'.
 newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
 
-instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where
-    WriterT x == WriterT y = eq1 x y
+instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where
+    eqWith eq (WriterT m1) (WriterT m2) = eqWith (eqWith2 eq (==)) m1 m2
 
-instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where
-    compare (WriterT x) (WriterT y) = compare1 x y
+instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where
+    compareWith comp (WriterT m1) (WriterT m2) =
+        compareWith (compareWith2 comp compare) m1 m2
 
-instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where
-    readsPrec = readsData $ readsUnary1 "WriterT" WriterT
+instance (Read w, Read1 m) => Read1 (WriterT w m) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith (readsPrecWith2 rp readsPrec))
+            "WriterT" WriterT
 
-instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where
-    showsPrec d (WriterT m) = showsUnary1 "WriterT" d m
+instance (Show w, Show1 m) => Show1 (WriterT w m) where
+    showsPrecWith sp d (WriterT m) =
+        showsUnaryWith (showsPrecWith (showsPrecWith2 sp showsPrec)) "WriterT" d m
 
-instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where eq1 = (==)
-instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where compare1 = compare
-instance (Read w, Read1 m) => Read1 (WriterT w m) where readsPrec1 = readsPrec
-instance (Show w, Show1 m) => Show1 (WriterT w m) where showsPrec1 = showsPrec
+instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1
+instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1
+instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where
+    readsPrec = readsPrec1
+instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where
+    showsPrec = showsPrec1
 
 -- | Extract the output from a writer computation.
 --
index 127d01a..1123143 100644 (file)
 -- Portability :  portable
 --
 -- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to
--- unary type constructors.
+-- unary and binary type constructors.
 --
 -- These classes are needed to express the constraints on arguments of
 -- transformers in portable Haskell.  Thus for a new transformer @T@,
 -- one might write instances like
 --
--- > instance (Eq1 f) => Eq (T f a) where ...
--- > instance (Ord1 f) => Ord (T f a) where ...
--- > instance (Read1 f) => Read (T f a) where ...
--- > instance (Show1 f) => Show (T f a) where ...
+-- > instance (Eq1 f) => Eq1 (T f) where ...
+-- > instance (Ord1 f) => Ord1 (T f) where ...
+-- > instance (Read1 f) => Read1 (T f) where ...
+-- > instance (Show1 f) => Show1 (T f) where ...
 --
--- If these instances can be defined, defining instances of the lifted
+-- If these instances can be defined, defining instances of the base
 -- classes is mechanical:
 --
--- > instance (Eq1 f) => Eq1 (T f) where eq1 = (==)
--- > instance (Ord1 f) => Ord1 (T f) where compare1 = compare
--- > instance (Read1 f) => Read1 (T f) where readsPrec1 = readsPrec
--- > instance (Show1 f) => Show1 (T f) where showsPrec1 = showsPrec
+-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1
+-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1
+-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1
+-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1
 --
 -----------------------------------------------------------------------------
 
 module Data.Functor.Classes (
     -- * Liftings of Prelude classes
+    -- ** For unary constructors
     Eq1(..),
     Ord1(..),
     Read1(..),
     Show1(..),
+    -- ** For binary constructors
+    Eq2(..),
+    Ord2(..),
+    Read2(..),
+    Show2(..),
     -- * Helper functions
     -- $example
     readsData,
+    readsUnaryWith,
+    readsBinaryWith,
+    showsUnaryWith,
+    showsBinaryWith,
+    -- ** Obsolete helpers
     readsUnary,
     readsUnary1,
     readsBinary1,
@@ -51,74 +62,228 @@ module Data.Functor.Classes (
     showsBinary1,
   ) where
 
-#if MIN_VERSION_base(4,8,0)
-import Control.Applicative (Const)
-#else
 import Control.Applicative (Const(Const))
-#endif
-import Data.Functor.Identity (Identity)
+import Data.Functor.Identity (Identity(Identity))
 
 -- | Lifting of the 'Eq' class to unary type constructors.
 class Eq1 f where
+    -- | Lift an equality test through the type constructor.
+    eqWith :: (a -> a -> Bool) -> f a -> f a -> Bool
+
+    -- | Lift the standard @('==')@ function through the type constructor.
     eq1 :: (Eq a) => f a -> f a -> Bool
+    eq1 = eqWith (==)
 
 -- | Lifting of the 'Ord' class to unary type constructors.
 class (Eq1 f) => Ord1 f where
+    -- | Lift a 'compare' function through the type constructor.
+    compareWith :: (a -> a -> Ordering) -> f a -> f a -> Ordering
+
+    -- | Lift the standard 'compare' function through the type constructor.
     compare1 :: (Ord a) => f a -> f a -> Ordering
+    compare1 = compareWith compare
 
 -- | Lifting of the 'Read' class to unary type constructors.
 class Read1 f where
+    -- | Lift a 'readsPrec' function through the type constructor.
+    readsPrecWith :: (Int -> ReadS a) -> Int -> ReadS (f a)
+
+    -- | Lift the standard 'readsPrec' function through the type constructor.
     readsPrec1 :: (Read a) => Int -> ReadS (f a)
+    readsPrec1 = readsPrecWith readsPrec
 
 -- | Lifting of the 'Show' class to unary type constructors.
 class Show1 f where
+    -- | Lift a 'showsPrec' function through the type constructor.
+    showsPrecWith :: (Int -> a -> ShowS) -> Int -> f a -> ShowS
+
+    -- | Lift the standard 'showsPrec' function through the type constructor.
     showsPrec1 :: (Show a) => Int -> f a -> ShowS
+    showsPrec1 = showsPrecWith showsPrec
+
+-- | Lifting of the 'Eq' class to binary type constructors.
+class Eq2 f where
+    -- | Lift equality tests through the type constructor.
+    eqWith2 :: (a -> a -> Bool) -> (b -> b -> Bool) -> f a b -> f a b -> Bool
+
+    -- | Lift the standard @('==')@ function through the type constructor.
+    eq2 :: (Eq a, Eq b) => f a b -> f a b -> Bool
+    eq2 = eqWith2 (==) (==)
+
+-- | Lifting of the 'Ord' class to binary type constructors.
+class (Eq2 f) => Ord2 f where
+    -- | Lift 'compare' functions through the type constructor.
+    compareWith2 :: (a -> a -> Ordering) -> (b -> b -> Ordering) ->
+        f a b -> f a b -> Ordering
+
+    -- | Lift the standard 'compare' function through the type constructor.
+    compare2 :: (Ord a, Ord b) => f a b -> f a b -> Ordering
+    compare2 = compareWith2 compare compare
+
+-- | Lifting of the 'Read' class to binary type constructors.
+class Read2 f where
+    -- | Lift 'readsPrec' functions through the type constructor.
+    readsPrecWith2 :: (Int -> ReadS a) -> (Int -> ReadS b) ->
+        Int -> ReadS (f a b)
+
+    -- | Lift the standard 'readsPrec' function through the type constructor.
+    readsPrec2 :: (Read a, Read b) => Int -> ReadS (f a b)
+    readsPrec2 = readsPrecWith2 readsPrec readsPrec
+
+-- | Lifting of the 'Show' class to binary type constructors.
+class Show2 f where
+    -- | Lift 'showsPrec' functions through the type constructor.
+    showsPrecWith2 :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->
+        Int -> f a b -> ShowS
+
+    -- | Lift the standard 'showsPrec' function through the type constructor.
+    showsPrec2 :: (Show a, Show b) => Int -> f a b -> ShowS
+    showsPrec2 = showsPrecWith2 showsPrec showsPrec
 
 -- Instances for Prelude type constructors
 
-instance Eq1 Maybe where eq1 = (==)
-instance Ord1 Maybe where compare1 = compare
-instance Read1 Maybe where readsPrec1 = readsPrec
-instance Show1 Maybe where showsPrec1 = showsPrec
+instance Eq1 Maybe where
+    eqWith _ Nothing Nothing = True
+    eqWith _ Nothing (Just _) = False
+    eqWith _ (Just _) Nothing = False
+    eqWith eq (Just x) (Just y) = eq x y
+
+instance Ord1 Maybe where
+    compareWith _ Nothing Nothing = EQ
+    compareWith _ Nothing (Just _) = LT
+    compareWith _ (Just _) Nothing = GT
+    compareWith comp (Just x) (Just y) = comp x y
+
+instance Read1 Maybe where
+    readsPrecWith rp d =
+         readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])
+         `mappend`
+         readsData (readsUnaryWith rp "Just" Just) d
+
+instance Show1 Maybe where
+    showsPrecWith _ _ Nothing = showString "Nothing"
+    showsPrecWith sp d (Just x) = showsUnaryWith sp "Just" d x
+
+instance Eq1 [] where
+    eqWith _ [] [] = True
+    eqWith _ [] (_:_) = False
+    eqWith _ (_:_) [] = False
+    eqWith eq (x:xs) (y:ys) = eq x y && eqWith eq xs ys
+
+instance Ord1 [] where
+    compareWith _ [] [] = EQ
+    compareWith _ [] (_:_) = LT
+    compareWith _ (_:_) [] = GT
+    compareWith comp (x:xs) (y:ys) = comp x y `mappend` compareWith comp xs ys
+
+instance Read1 [] where
+    readsPrecWith rp _ = readParen False $ \ r ->
+        [pr | ("[",s)  <- lex r, pr <- readl s]
+      where
+        readl s = [([],t) | ("]",t) <- lex s] ++
+            [(x:xs,u) | (x,t) <- rp 0 s, (xs,u) <- readl' t]
+        readl' s = [([],t) | ("]",t) <- lex s] ++
+            [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp 0 t, (xs,v) <- readl' u]
+
+
+instance Show1 [] where
+    showsPrecWith sp _ [] = showString "[]"
+    showsPrecWith sp _ (x:xs) = showChar '[' . sp 0 x . showl xs
+      where
+        showl []     = showChar ']'
+        showl (x:xs) = showChar ',' . sp 0 x . showl xs
+
+instance Eq2 (,) where
+    eqWith2 eq1 eq2 (x1, y1) (x2, y2) = eq1 x1 x2 && eq2 y1 y2
+
+instance Ord2 (,) where
+    compareWith2 comp1 comp2 (x1, y1) (x2, y2) =
+        comp1 x1 x2 `mappend` comp2 y1 y2
+
+instance Read2 (,) where
+    readsPrecWith2 rp1 rp2 _ = readParen False $ \ r ->
+        [((x,y), w) | ("(",s) <- lex r,
+                      (x,t)   <- rp1 0 s,
+                      (",",u) <- lex t,
+                      (y,v)   <- rp2 0 u,
+                      (")",w) <- lex v]
 
-instance Eq1 [] where eq1 = (==)
-instance Ord1 [] where compare1 = compare
-instance Read1 [] where readsPrec1 = readsPrec
-instance Show1 [] where showsPrec1 = showsPrec
+instance Show2 (,) where
+    showsPrecWith2 sp1 sp2 _ (x, y) =
+        showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'
 
-instance (Eq a) => Eq1 ((,) a) where eq1 = (==)
-instance (Ord a) => Ord1 ((,) a) where compare1 = compare
-instance (Read a) => Read1 ((,) a) where readsPrec1 = readsPrec
-instance (Show a) => Show1 ((,) a) where showsPrec1 = showsPrec
+instance (Eq a) => Eq1 ((,) a) where
+    eqWith = eqWith2 (==)
 
-instance (Eq a) => Eq1 (Either a) where eq1 = (==)
-instance (Ord a) => Ord1 (Either a) where compare1 = compare
-instance (Read a) => Read1 (Either a) where readsPrec1 = readsPrec
-instance (Show a) => Show1 (Either a) where showsPrec1 = showsPrec
+instance (Ord a) => Ord1 ((,) a) where
+    compareWith = compareWith2 compare
+
+instance (Read a) => Read1 ((,) a) where
+    readsPrecWith = readsPrecWith2 readsPrec
+
+instance (Show a) => Show1 ((,) a) where
+    showsPrecWith = showsPrecWith2 showsPrec
+
+instance Eq2 Either where
+    eqWith2 eq1 _ (Left x) (Left y) = eq1 x y
+    eqWith2 _ _ (Left _) (Right _) = False
+    eqWith2 _ _ (Right _) (Left _) = False
+    eqWith2 _ eq2 (Right x) (Right y) = eq2 x y
+
+instance Ord2 Either where
+    compareWith2 comp1 _ (Left x) (Left y) = comp1 x y
+    compareWith2 _ _ (Left _) (Right _) = LT
+    compareWith2 _ _ (Right _) (Left _) = GT
+    compareWith2 _ comp2 (Right x) (Right y) = comp2 x y
+
+instance Read2 Either where
+    readsPrecWith2 rp1 rp2 = readsData $
+         readsUnaryWith rp1 "Left" Left `mappend`
+         readsUnaryWith rp2 "Right" Right
+
+instance Show2 Either where
+    showsPrecWith2 sp1 _ d (Left x) = showsUnaryWith sp1 "Left" d x
+    showsPrecWith2 _ sp2 d (Right x) = showsUnaryWith sp2 "Right" d x
+
+instance (Eq a) => Eq1 (Either a) where
+    eqWith = eqWith2 (==)
+
+instance (Ord a) => Ord1 (Either a) where
+    compareWith = compareWith2 compare
+
+instance (Read a) => Read1 (Either a) where
+    readsPrecWith = readsPrecWith2 readsPrec
+
+instance (Show a) => Show1 (Either a) where
+    showsPrecWith = showsPrecWith2 showsPrec
 
 -- Instances for other functors defined in the base package
 
-instance Eq1 Identity where eq1 = (==)
-instance Ord1 Identity where compare1 = compare
-instance Read1 Identity where readsPrec1 = readsPrec
-instance Show1 Identity where showsPrec1 = showsPrec
-
-#if MIN_VERSION_base(4,8,0)
--- Eq, etc instances for Const were introduced in base-4.8
-instance (Eq a) => Eq1 (Const a) where eq1 = (==)
-instance (Ord a) => Ord1 (Const a) where compare1 = compare
-instance (Read a) => Read1 (Const a) where readsPrec1 = readsPrec
-instance (Show a) => Show1 (Const a) where showsPrec1 = showsPrec
-#else
+instance Eq1 Identity where
+    eqWith eq (Identity x) (Identity y) = eq x y
+
+instance Ord1 Identity where
+    compareWith comp (Identity x) (Identity y) = comp x y
+
+instance Read1 Identity where
+    readsPrecWith rp = readsData $
+         readsUnaryWith rp "Identity" Identity
+
+instance Show1 Identity where
+    showsPrecWith sp d (Identity x) = showsUnaryWith sp "Identity" d x
+
 instance (Eq a) => Eq1 (Const a) where
-    eq1 (Const x) (Const y) = x == y
+    eqWith _ (Const x) (Const y) = x == y
+
 instance (Ord a) => Ord1 (Const a) where
-    compare1 (Const x) (Const y) = compare x y
+    compareWith _ (Const x) (Const y) = compare x y
+
 instance (Read a) => Read1 (Const a) where
-    readsPrec1 = readsData $ readsUnary "Const" Const
+    readsPrecWith _ = readsData $
+         readsUnaryWith readsPrec "Const" Const
+
 instance (Show a) => Show1 (Const a) where
-    showsPrec1 d (Const x) = showsUnary "Const" d x
-#endif
+    showsPrecWith _ d (Const x) = showsUnaryWith showsPrec "Const" d x
 
 -- Building blocks
 
@@ -131,20 +296,54 @@ readsData :: (String -> ReadS a) -> Int -> ReadS a
 readsData reader d =
     readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]
 
+-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor
+-- and then parses its argument using @rp@.
+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]
+
+-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary
+-- data constructor and then parses its arguments using @rp1@ and @rp2@
+-- respectively.
+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]
+
+-- | @'showsUnaryWith' sp n d x@ produces the string representation of a
+-- unary data constructor with name @n@ and argument @x@, in precedence
+-- context @d@.
+showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
+showsUnaryWith sp name d x = showParen (d > 10) $
+    showString name . showChar ' ' . sp 11 x
+
+-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string
+-- representation of a binary data constructor with name @n@ and arguments
+-- @x@ and @y@, in precedence context @d@.
+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
+
+-- Obsolete building blocks
+
 -- | @'readsUnary' n c n'@ matches the name of a unary data constructor
 -- and then parses its argument using 'readsPrec'.
+{-# DEPRECATED readsUnary "Use readsUnaryWith to define readsPrecWith" #-}
 readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t
 readsUnary name cons kw s =
     [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]
 
 -- | @'readsUnary1' n c n'@ matches the name of a unary data constructor
 -- and then parses its argument using 'readsPrec1'.
+{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define readsPrecWith" #-}
 readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t
 readsUnary1 name cons kw s =
     [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]
 
 -- | @'readsBinary1' n c n'@ matches the name of a binary data constructor
 -- and then parses its arguments using 'readsPrec1'.
+{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define readsPrecWith" #-}
 readsBinary1 :: (Read1 f, Read1 g, Read a) =>
     String -> (f a -> g a -> t) -> String -> ReadS t
 readsBinary1 name cons kw s =
@@ -153,19 +352,22 @@ readsBinary1 name cons kw s =
 
 -- | @'showsUnary' n d x@ produces the string representation of a unary data
 -- constructor with name @n@ and argument @x@, in precedence context @d@.
+{-# DEPRECATED showsUnary "Use showsUnaryWith to define showsPrecWith" #-}
 showsUnary :: (Show a) => String -> Int -> a -> ShowS
 showsUnary name d x = showParen (d > 10) $
     showString name . showChar ' ' . showsPrec 11 x
 
 -- | @'showsUnary1' n d x@ produces the string representation of a unary data
 -- constructor with name @n@ and argument @x@, in precedence context @d@.
+{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define showsPrecWith" #-}
 showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS
 showsUnary1 name d x = showParen (d > 10) $
     showString name . showChar ' ' . showsPrec1 11 x
 
--- | @'showsBinary1' n d x@ produces the string representation of a binary
+-- | @'showsBinary1' n d x y@ produces the string representation of a binary
 -- data constructor with name @n@ and arguments @x@ and @y@, in precedence
 -- context @d@.
+{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define showsPrecWith" #-}
 showsBinary1 :: (Show1 f, Show1 g, Show a) =>
     String -> Int -> f a -> g a -> ShowS
 showsBinary1 name d x y = showParen (d > 10) $
@@ -176,21 +378,24 @@ showsBinary1 name d x y = showParen (d > 10) $
 These functions can be used to assemble 'Read' and 'Show' instances for
 new algebraic types.  For example, given the definition
 
-> data T f a = Zero a | One (f a) | Two (f a) (f a)
+> data T f a = Zero a | One (f a) | Two a (f a)
 
-a standard 'Read' instance may be defined as
+a standard 'Read1' instance may be defined as
 
-> instance (Read1 f, Read a) => Read (T f a) where
->     readsPrec = readsData $
->         readsUnary "Zero" Zero `mappend`
->         readsUnary1 "One" One `mappend`
->         readsBinary1 "Two" Two
+> instance (Read1 f) => Read1 (T f) where
+>     readsPrecWith rp = readsData $
+>         readsUnaryWith rp "Zero" Zero `mappend`
+>         readsUnaryWith (readsPrecWith rp) "One" One `mappend`
+>         readsBinaryWith rp (readsPrecWith rp) "Two" Two
 
-and the corresponding 'Show' instance as
+and the corresponding 'Show1' instance as
 
-> instance (Show1 f, Show a) => Show (T f a) where
->     showsPrec d (Zero x) = showsUnary "Zero" d x
->     showsPrec d (One x) = showsUnary1 "One" d x
->     showsPrec d (Two x y) = showsBinary1 "Two" d x y
+> instance (Show1 f) => Show1 (T f) where
+>     showsPrecWith sp d (Zero x) =
+>         showsUnaryWith sp "Zero" d x
+>     showsPrecWith sp d (One x) =
+>         showsUnaryWith (showsPrecWith sp) "One" d x
+>     showsPrecWith sp d (Two x y) =
+>         showsBinaryWith sp (showsPrecWith sp) "Two" d x y
 
 -}
index 58fb083..19f8c47 100644 (file)
@@ -32,45 +32,36 @@ infixr 9 `Compose`
 -- but the composition of monads is not always a monad.
 newtype Compose f g a = Compose { getCompose :: f (g a) }
 
--- Instances of Prelude classes
-
--- kludge to get type with the same instances as g a
-newtype Apply g a = Apply (g a)
+-- Instances of lifted Prelude classes
 
-getApply :: Apply g a -> g a
-getApply (Apply x) = x
+instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
+    eqWith eq (Compose x) (Compose y) = eqWith (eqWith eq) x y
 
-instance (Eq1 g, Eq a) => Eq (Apply g a) where
-    Apply x == Apply y = eq1 x y
+instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
+    compareWith comp (Compose x) (Compose y) =
+        compareWith (compareWith comp) x y
 
-instance (Ord1 g, Ord a) => Ord (Apply g a) where
-    compare (Apply x) (Apply y) = compare1 x y
+instance (Read1 f, Read1 g) => Read1 (Compose f g) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith (readsPrecWith rp)) "Compose" Compose
 
-instance (Read1 g, Read a) => Read (Apply g a) where
-    readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]
+instance (Show1 f, Show1 g) => Show1 (Compose f g) where
+    showsPrecWith sp d (Compose x) =
+        showsUnaryWith (showsPrecWith (showsPrecWith sp)) "Compose" d x
 
-instance (Show1 g, Show a) => Show (Apply g a) where
-    showsPrec d (Apply x) = showsPrec1 d x
-
-instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
-    Compose x == Compose y = eq1 (fmap Apply x) (fmap Apply y)
+-- Instances of Prelude classes
 
-instance (Functor f, Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
-    compare (Compose x) (Compose y) = compare1 (fmap Apply x) (fmap Apply y)
+instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
+    (==) = eq1
 
-instance (Functor f, Read1 f, Read1 g, Read a) => Read (Compose f g a) where
-    readsPrec = readsData $ readsUnary1 "Compose" (Compose . fmap getApply)
+instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
+    compare = compare1
 
-instance (Functor f, Show1 f, Show1 g, Show a) => Show (Compose f g a) where
-    showsPrec d (Compose x) = showsUnary1 "Compose" d (fmap Apply x)
+instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
+    readsPrec = readsPrec1
 
-instance (Functor f, Eq1 f, Eq1 g) => Eq1 (Compose f g) where eq1 = (==)
-instance (Functor f, Ord1 f, Ord1 g) => Ord1 (Compose f g) where
-    compare1 = compare
-instance (Functor f, Read1 f, Read1 g) => Read1 (Compose f g) where
-    readsPrec1 = readsPrec
-instance (Functor f, Show1 f, Show1 g) => Show1 (Compose f g) where
-    showsPrec1 = showsPrec
+instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
+    showsPrec = showsPrec1
 
 -- Functor instances
 
index bdfdb5f..aaea088 100644 (file)
@@ -34,15 +34,26 @@ newtype Constant a b = Constant { getConstant :: a }
 -- newtype if the field were removed.
 
 instance (Read a) => Read (Constant a b) where
-    readsPrec = readsData $ readsUnary "Constant" Constant
+    readsPrec = readsData $
+         readsUnaryWith readsPrec "Constant" Constant
 
 instance (Show a) => Show (Constant a b) where
-    showsPrec d (Constant x) = showsUnary "Constant" d x
+    showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x
 
-instance (Eq a) => Eq1 (Constant a) where eq1 = (==)
-instance (Ord a) => Ord1 (Constant a) where compare1 = compare
-instance (Read a) => Read1 (Constant a) where readsPrec1 = readsPrec
-instance (Show a) => Show1 (Constant a) where showsPrec1 = showsPrec
+-- Instances of lifted Prelude classes
+
+instance (Eq a) => Eq1 (Constant a) where
+    eqWith _ (Constant x) (Constant y) = x == y
+
+instance (Ord a) => Ord1 (Constant a) where
+    compareWith _ (Constant x) (Constant y) = compare x y
+
+instance (Read a) => Read1 (Constant a) where
+    readsPrecWith _ = readsData $
+         readsUnaryWith readsPrec "Constant" Constant
+
+instance (Show a) => Show1 (Constant a) where
+    showsPrecWith _ d (Constant x) = showsUnaryWith showsPrec "Constant" d x
 
 instance Functor (Constant a) where
     fmap _ (Constant x) = Constant x
index 629440f..ef3d0e4 100644 (file)
@@ -30,23 +30,29 @@ import Data.Traversable (Traversable(traverse))
 -- | Lifted product of functors.
 data Product f g a = Pair (f a) (g a)
 
-instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) where
-    Pair x1 y1 == Pair x2 y2 = eq1 x1 x2 && eq1 y1 y2
+instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
+    eqWith eq (Pair x1 y1) (Pair x2 y2) = eqWith eq x1 x2 && eqWith eq y1 y2
 
-instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
-    compare (Pair x1 y1) (Pair x2 y2) =
-        compare1 x1 x2 `mappend` compare1 y1 y2
+instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
+    compareWith comp (Pair x1 y1) (Pair x2 y2) =
+        compareWith comp x1 x2 `mappend` compareWith comp y1 y2
 
-instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
-    readsPrec = readsData $ readsBinary1 "Pair" Pair
+instance (Read1 f, Read1 g) => Read1 (Product f g) where
+    readsPrecWith rp = readsData $
+        readsBinaryWith (readsPrecWith rp) (readsPrecWith rp) "Pair" Pair
 
-instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
-    showsPrec d (Pair x y) = showsBinary1 "Pair" d x y
+instance (Show1 f, Show1 g) => Show1 (Product f g) where
+    showsPrecWith sp d (Pair x y) =
+        showsBinaryWith (showsPrecWith sp) (showsPrecWith sp) "Pair" d x y
 
-instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where eq1 = (==)
-instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where compare1 = compare
-instance (Read1 f, Read1 g) => Read1 (Product f g) where readsPrec1 = readsPrec
-instance (Show1 f, Show1 g) => Show1 (Product f g) where showsPrec1 = showsPrec
+instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
+    where (==) = eq1
+instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
+    compare = compare1
+instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
+    readsPrec = readsPrec1
+instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
+    showsPrec = showsPrec1
 
 instance (Functor f, Functor g) => Functor (Product f g) where
     fmap f (Pair x y) = Pair (fmap f x) (fmap f y)
index 876f9ea..5b2159c 100644 (file)
@@ -33,22 +33,24 @@ import Data.Monoid
 -- that process the elements in the reverse order.
 newtype Reverse f a = Reverse { getReverse :: f a }
 
-instance (Eq1 f, Eq a) => Eq (Reverse f a) where
-    Reverse x == Reverse y = eq1 x y
+instance (Eq1 f) => Eq1 (Reverse f) where
+    eqWith eq (Reverse x) (Reverse y) = eqWith eq x y
 
-instance (Ord1 f, Ord a) => Ord (Reverse f a) where
-    compare (Reverse x) (Reverse y) = compare1 x y
+instance (Ord1 f) => Ord1 (Reverse f) where
+    compareWith comp (Reverse x) (Reverse y) = compareWith comp x y
 
-instance (Read1 f, Read a) => Read (Reverse f a) where
-    readsPrec = readsData $ readsUnary1 "Reverse" Reverse
+instance (Read1 f) => Read1 (Reverse f) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith rp) "Reverse" Reverse
 
-instance (Show1 f, Show a) => Show (Reverse f a) where
-    showsPrec d (Reverse x) = showsUnary1 "Reverse" d x
+instance (Show1 f) => Show1 (Reverse f) where
+    showsPrecWith sp d (Reverse x) =
+        showsUnaryWith (showsPrecWith sp) "Reverse" d x
 
-instance (Eq1 f) => Eq1 (Reverse f) where eq1 = (==)
-instance (Ord1 f) => Ord1 (Reverse f) where compare1 = compare
-instance (Read1 f) => Read1 (Reverse f) where readsPrec1 = readsPrec
-instance (Show1 f) => Show1 (Reverse f) where showsPrec1 = showsPrec
+instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1
 
 -- | Derived instance.
 instance (Functor f) => Functor (Reverse f) where
index 649cf64..ed802fe 100644 (file)
@@ -28,29 +28,35 @@ import Data.Traversable (Traversable(traverse))
 -- | Lifted sum of functors.
 data Sum f g a = InL (f a) | InR (g a)
 
-instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where
-    InL x1 == InL x2 = eq1 x1 x2
-    InR y1 == InR y2 = eq1 y1 y2
-    _ == _ = False
+instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where
+    eqWith eq (InL x1) (InL x2) = eqWith eq x1 x2
+    eqWith eq (InL _) (InR _) = False
+    eqWith eq (InR _) (InL _) = False
+    eqWith eq (InR y1) (InR y2) = eqWith eq y1 y2
 
-instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where
-    compare (InL x1) (InL x2) = compare1 x1 x2
-    compare (InL _) (InR _) = LT
-    compare (InR _) (InL _) = GT
-    compare (InR y1) (InR y2) = compare1 y1 y2
+instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where
+    compareWith comp (InL x1) (InL x2) = compareWith comp x1 x2
+    compareWith comp (InL _) (InR _) = LT
+    compareWith comp (InR _) (InL _) = GT
+    compareWith comp (InR y1) (InR y2) = compareWith comp y1 y2
 
-instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where
-    readsPrec = readsData $
-        readsUnary1 "InL" InL `mappend` readsUnary1 "InR" InR
+instance (Read1 f, Read1 g) => Read1 (Sum f g) where
+    readsPrecWith rp = readsData $
+        readsUnaryWith (readsPrecWith rp) "InL" InL `mappend`
+        readsUnaryWith (readsPrecWith rp) "InR" InR
 
-instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where
-    showsPrec d (InL x) = showsUnary1 "InL" d x
-    showsPrec d (InR y) = showsUnary1 "InR" d y
+instance (Show1 f, Show1 g) => Show1 (Sum f g) where
+    showsPrecWith sp d (InL x) = showsUnaryWith (showsPrecWith sp) "InL" d x
+    showsPrecWith sp d (InR y) = showsUnaryWith (showsPrecWith sp) "InR" d y
 
-instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where eq1 = (==)
-instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where compare1 = compare
-instance (Read1 f, Read1 g) => Read1 (Sum f g) where readsPrec1 = readsPrec
-instance (Show1 f, Show1 g) => Show1 (Sum f g) where showsPrec1 = showsPrec
+instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where
+    (==) = eq1
+instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where
+    compare = compare1
+instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where
+    readsPrec = readsPrec1
+instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where
+    showsPrec = showsPrec1
 
 instance (Functor f, Functor g) => Functor (Sum f g) where
     fmap f (InL x) = InL (fmap f x)