{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_transformers #define MIN_VERSION_transformers(a,b,c) 1 #endif -- | -- Module : Data.Functor.Classes -- Copyright : (c) Ross Paterson 2013, Edward Kmett 2014 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- Prelude classes, lifted to unary type constructors. module Data.Functor.Classes ( -- * Liftings of Prelude classes Eq1(..), Ord1(..), Read1(..), Show1(..), -- * Helper functions readsData, readsUnary, readsUnary1, readsBinary1, showsUnary, showsUnary1, showsBinary1, ) where import Control.Monad.Trans.Error import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Identity import Data.Functor.Product import Data.Monoid (Monoid(mappend)) #if MIN_VERSION_transformers(0,3,0) import Control.Applicative.Lift import Control.Applicative.Backwards import Data.Functor.Reverse #endif instance Show a => Show (Identity a) where showsPrec d (Identity a) = showParen (d > 10) $ showString "Identity " . showsPrec 11 a instance Read a => Read (Identity a) where readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s]) instance Eq a => Eq (Identity a) where Identity a == Identity b = a == b instance Ord a => Ord (Identity a) where compare (Identity a) (Identity b) = compare a b instance Show a => Show (Constant a b) where showsPrec d (Constant a) = showParen (d > 10) $ showString "Constant " . showsPrec 11 a instance Read a => Read (Constant a b) where readsPrec d = readParen (d > 10) (\r -> [(Constant m,t) | ("Constant",s) <- lex r, (m,t) <- readsPrec 11 s]) instance Eq a => Eq (Constant a b) where Constant a == Constant b = a == b instance Ord a => Ord (Constant a b) where compare (Constant a) (Constant b) = compare a b -- | Lifting of the 'Eq' class to unary type constructors. class Eq1 f where eq1 :: (Eq a) => f a -> f a -> Bool -- | Lifting of the 'Ord' class to unary type constructors. class (Eq1 f) => Ord1 f where compare1 :: (Ord a) => f a -> f a -> Ordering -- | Lifting of the 'Read' class to unary type constructors. class Read1 f where readsPrec1 :: (Read a) => Int -> ReadS (f a) -- | Lifting of the 'Show' class to unary type constructors. class Show1 f where showsPrec1 :: (Show a) => Int -> f a -> ShowS -- 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 [] where eq1 = (==) instance Ord1 [] where compare1 = compare instance Read1 [] where readsPrec1 = readsPrec instance Show1 [] where showsPrec1 = showsPrec 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 (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 -- Building blocks -- | @'readsData' p d@ is a parser for datatypes where each alternative -- begins with a data constructor. It parses the constructor and -- passes it to @p@. Parsers for various constructors can be constructed -- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with -- @mappend@ from the @Monoid@ class. readsData :: (String -> ReadS a) -> Int -> ReadS a readsData reader d = readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] -- | @'readsUnary' n c n'@ matches the name of a unary data constructor -- and then parses its argument using 'readsPrec'. 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'. 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'. readsBinary1 :: (Read1 f, Read1 g, Read a) => String -> (f a -> g a -> t) -> String -> ReadS t readsBinary1 name cons kw s = [(cons x y,u) | kw == name, (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] -- | @'showsUnary' n d x@ produces the string representation of a unary data -- constructor with name @n@ and argument @x@, in precedence context @d@. 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@. 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 -- data constructor with name @n@ and arguments @x@ and @y@, in precedence -- context @d@. showsBinary1 :: (Show1 f, Show1 g, Show a) => String -> Int -> f a -> g a -> ShowS showsBinary1 name d x y = showParen (d > 10) $ showString name . showChar ' ' . showsPrec1 11 x . showChar ' ' . showsPrec1 11 y instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where ErrorT x == ErrorT y = eq1 x y instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare (ErrorT x) (ErrorT y) = compare1 x y instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where readsPrec = readsData $ readsUnary1 "ErrorT" ErrorT instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where showsPrec d (ErrorT m) = showsUnary1 "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 (Eq1 f, Eq a) => Eq (IdentityT f a) where IdentityT x == IdentityT y = eq1 x y instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare (IdentityT x) (IdentityT y) = compare1 x y instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsData $ readsUnary1 "IdentityT" IdentityT instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec d (IdentityT m) = showsUnary1 "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 m, Eq a) => Eq (ListT m a) where ListT x == ListT y = eq1 x y instance (Ord1 m, Ord a) => Ord (ListT m a) where compare (ListT x) (ListT y) = compare1 x y instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsData $ readsUnary1 "ListT" ListT instance (Show1 m, Show a) => Show (ListT m a) where showsPrec d (ListT m) = showsUnary1 "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 (MaybeT m a) where MaybeT x == MaybeT y = eq1 x y instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare (MaybeT x) (MaybeT y) = compare1 x y instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsData $ readsUnary1 "MaybeT" MaybeT instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec d (MaybeT m) = showsUnary1 "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 (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where Lazy.WriterT x == Lazy.WriterT y = eq1 x y instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where compare (Lazy.WriterT x) (Lazy.WriterT y) = compare1 x y instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where readsPrec = readsData $ readsUnary1 "WriterT" Lazy.WriterT instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where showsPrec d (Lazy.WriterT m) = showsUnary1 "WriterT" d m instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where eq1 = (==) instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where compare1 = compare instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where readsPrec1 = readsPrec instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where showsPrec1 = showsPrec instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where Strict.WriterT x == Strict.WriterT y = eq1 x y instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where compare (Strict.WriterT x) (Strict.WriterT y) = compare1 x y instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where readsPrec = readsData $ readsUnary1 "WriterT" Strict.WriterT instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where showsPrec d (Strict.WriterT m) = showsUnary1 "WriterT" d m instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where eq1 = (==) instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where compare1 = compare instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where readsPrec1 = readsPrec instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where showsPrec1 = showsPrec 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) 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 (Functor f, Read1 f, Read1 g, Read a) => Read (Compose f g a) where readsPrec = readsData $ readsUnary1 "Compose" (Compose . fmap getApply) 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 (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 (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 (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 (Read1 f, Read1 g, Read a) => Read (Product f g a) where readsPrec = readsData $ readsBinary1 "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 (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 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 instance Eq1 Identity where eq1 = (==) instance Ord1 Identity where compare1 = compare instance Read1 Identity where readsPrec1 = readsPrec instance Show1 Identity where showsPrec1 = showsPrec -- Instances of Prelude classes -- kludge to get type with the same instances as g a newtype Apply g a = Apply (g a) getApply :: Apply g a -> g a getApply (Apply x) = x instance (Eq1 g, Eq a) => Eq (Apply g a) where Apply x == Apply y = eq1 x y instance (Ord1 g, Ord a) => Ord (Apply g a) where compare (Apply x) (Apply y) = compare1 x y instance (Read1 g, Read a) => Read (Apply g a) where readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s] instance (Show1 g, Show a) => Show (Apply g a) where showsPrec d (Apply x) = showsPrec1 d x #if MIN_VERSION_transformers(0,3,0) 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, Eq a) => Eq (Backwards f a) where Backwards x == Backwards y = eq1 x y instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare (Backwards x) (Backwards y) = compare1 x y instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsData $ readsUnary1 "Backwards" Backwards instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec d (Backwards x) = showsUnary1 "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 (Reverse f a) where Reverse x == Reverse y = eq1 x y instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare (Reverse x) (Reverse y) = compare1 x y instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsData $ readsUnary1 "Reverse" Reverse instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec d (Reverse x) = showsUnary1 "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 #endif