transformers-compat 0.4.0.4 → 0.5.0.2
raw patch · 11 files changed
+1364/−324 lines, 11 filesdep +ghc-primdep ~basedep ~transformers
Dependencies added: ghc-prim
Dependency ranges changed: base, transformers
Files
- 0.2/Control/Applicative/Backwards.hs +33/−22
- 0.2/Control/Applicative/Lift.hs +69/−27
- 0.2/Data/Functor/Reverse.hs +30/−19
- 0.3/Control/Monad/Signatures.hs +27/−0
- 0.3/Control/Monad/Trans/Except.hs +48/−17
- 0.3/Data/Functor/Classes.hs +661/−210
- 0.3/Data/Functor/Sum.hs +93/−19
- LICENSE +1/−1
- README.markdown +1/−1
- src/Control/Monad/Trans/Instances.hs +386/−0
- transformers-compat.cabal +15/−8
0.2/Control/Applicative/Backwards.hs view
@@ -1,3 +1,13 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+# endif+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+# endif+#endif -- | -- Module : Control.Applicative.Backwards -- Copyright : (c) Russell O'Connor 2009@@ -14,16 +24,36 @@ -- @transformers@ versions before 3.0. module Control.Applicative.Backwards where +import Data.Functor.Classes+ import Prelude hiding (foldr, foldr1, foldl, foldl1) import Control.Applicative import Data.Foldable-import Data.Functor.Classes import Data.Traversable -- | The same functor, but with an 'Applicative' instance that performs -- actions in the reverse order. newtype Backwards f a = Backwards { forwards :: f a } +instance (Eq1 f) => Eq1 (Backwards f) where+ liftEq eq (Backwards x) (Backwards y) = liftEq eq x y++instance (Ord1 f) => Ord1 (Backwards f) where+ liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y++instance (Read1 f) => Read1 (Backwards f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards++instance (Show1 f) => Show1 (Backwards f) where+ liftShowsPrec sp sl d (Backwards x) =+ showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x++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 fmap f (Backwards a) = Backwards (fmap f a)@@ -43,29 +73,10 @@ foldMap f (Backwards t) = foldMap f t foldr f z (Backwards t) = foldr f z t foldl f z (Backwards t) = foldl f z t- foldr1 f (Backwards t) = foldl1 f t- foldl1 f (Backwards t) = foldr1 f t+ foldr1 f (Backwards t) = foldr1 f t+ foldl1 f (Backwards t) = foldl1 f t -- | Derived instance. instance (Traversable f) => Traversable (Backwards f) where traverse f (Backwards t) = fmap Backwards (traverse f t) sequenceA (Backwards t) = fmap Backwards (sequenceA t)---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-
0.2/Control/Applicative/Lift.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+# elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+# endif+#endif -- | -- Module : Control.Applicative.Lift -- Copyright : (c) Ross Paterson 2010@@ -13,45 +22,54 @@ -- @transformers@ versions before 3.0. module Control.Applicative.Lift (- Lift(..), unLift,+ -- * Lifting an applicative+ Lift(..),+ unLift,+ mapLift, -- * Collecting errors- Errors, failure+ Errors,+ runErrors,+ failure ) where +import Data.Functor.Classes+ import Control.Applicative import Data.Foldable (Foldable(foldMap)) import Data.Functor.Constant-import Data.Functor.Classes-import Data.Monoid+import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) -- | Applicative functor formed by adding pure computations to a given -- 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 (Eq1 f) => Eq1 (Lift f) where+ liftEq eq (Pure x1) (Pure x2) = eq x1 x2+ liftEq _ (Pure _) (Other _) = False+ liftEq _ (Other _) (Pure _) = False+ liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 -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 (Ord1 f) => Ord1 (Lift f) where+ liftCompare comp (Pure x1) (Pure x2) = comp x1 x2+ liftCompare _ (Pure _) (Other _) = LT+ liftCompare _ (Other _) (Pure _) = GT+ liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 -instance (Read1 f, Read a) => Read (Lift f a) where- readsPrec = readsData $- readsUnary "Pure" Pure `mappend` readsUnary1 "Other" Other+instance (Read1 f) => Read1 (Lift f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith rp "Pure" Pure `mappend`+ readsUnaryWith (liftReadsPrec rp rl) "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 (Show1 f) => Show1 (Lift f) where+ liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x+ liftShowsPrec sp sl d (Other y) =+ showsUnaryWith (liftShowsPrec sp sl) "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 (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)@@ -74,23 +92,47 @@ Other f <*> Other y = Other (f <*> y) -- | A combination is 'Pure' only either part is.-instance Alternative f => Alternative (Lift f) where+instance (Alternative f) => Alternative (Lift f) where empty = Other empty Pure x <|> _ = Pure x Other _ <|> Pure y = Pure y Other x <|> Other y = Other (x <|> y) -- | Projection to the other functor.-unLift :: Applicative f => Lift f a -> f a+unLift :: (Applicative f) => Lift f a -> f a unLift (Pure x) = pure x unLift (Other e) = e +-- | Apply a transformation to the other computation.+mapLift :: (f a -> g a) -> Lift f a -> Lift g a+mapLift _ (Pure x) = Pure x+mapLift f (Other e) = Other (f e)+ -- | An applicative functor that collects a monoid (e.g. lists) of errors. -- A sequence of computations fails if any of its components do, but--- unlike monads made with 'ErrorT' from "Control.Monad.Trans.Error",+-- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except", -- these computations continue after an error, collecting all the errors.+--+-- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@+--+-- * @'pure' f '<*>' 'failure' e = 'failure' e@+--+-- * @'failure' e '<*>' 'pure' x = 'failure' e@+--+-- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@+-- type Errors e = Lift (Constant e) +-- | Extractor for computations with accumulating errors.+--+-- * @'runErrors' ('pure' x) = 'Right' x@+--+-- * @'runErrors' ('failure' e) = 'Left' e@+--+runErrors :: Errors e a -> Either e a+runErrors (Other (Constant e)) = Left e+runErrors (Pure x) = Right x+ -- | Report an error.-failure :: Monoid e => e -> Errors e a+failure :: e -> Errors e a failure e = Other (Constant e)
0.2/Data/Functor/Reverse.hs view
@@ -1,3 +1,13 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+# endif+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+# endif+#endif -- | -- Module : Data.Functor.Reverse -- Copyright : (c) Russell O'Connor 2009@@ -16,11 +26,11 @@ module Data.Functor.Reverse where import Control.Applicative.Backwards+import Data.Functor.Classes import Prelude hiding (foldr, foldr1, foldl, foldl1) import Control.Applicative import Data.Foldable-import Data.Functor.Classes import Data.Traversable import Data.Monoid @@ -28,6 +38,25 @@ -- that process the elements in the reverse order. newtype Reverse f a = Reverse { getReverse :: f a } +instance (Eq1 f) => Eq1 (Reverse f) where+ liftEq eq (Reverse x) (Reverse y) = liftEq eq x y++instance (Ord1 f) => Ord1 (Reverse f) where+ liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y++instance (Read1 f) => Read1 (Reverse f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse++instance (Show1 f) => Show1 (Reverse f) where+ liftShowsPrec sp sl d (Reverse x) =+ showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x++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 fmap f (Reverse a) = Reverse (fmap f a)@@ -56,21 +85,3 @@ fmap Reverse . forwards $ traverse (Backwards . f) t sequenceA (Reverse t) = fmap Reverse . forwards $ sequenceA (fmap Backwards t)--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-
0.3/Control/Monad/Signatures.hs view
@@ -1,3 +1,13 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+# endif+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+# endif+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Signatures@@ -9,6 +19,7 @@ -- Portability : portable -- -- Signatures for monad operations that require specialized lifting.+-- Each signature has a uniformity property that the lifting should satisfy. ----------------------------------------------------------------------------- module Control.Monad.Signatures (@@ -17,16 +28,32 @@ -- | Signature of the @callCC@ operation, -- introduced in "Control.Monad.Trans.Cont".+-- Any lifting function @liftCallCC@ should satisfy+--+-- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@+-- type CallCC m a b = ((a -> m b) -> m a) -> m a -- | Signature of the @catchE@ operation, -- introduced in "Control.Monad.Trans.Except".+-- Any lifting function @liftCatch@ should satisfy+--+-- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@+-- type Catch e m a = m a -> (e -> m a) -> m a -- | Signature of the @listen@ operation, -- introduced in "Control.Monad.Trans.Writer".+-- Any lifting function @liftListen@ should satisfy+--+-- * @'lift' . liftListen = liftListen . 'lift'@+-- type Listen w m a = m a -> m (a, w) -- | Signature of the @pass@ operation, -- introduced in "Control.Monad.Trans.Writer".+-- Any lifting function @liftPass@ should satisfy+--+-- * @'lift' . liftPass = liftPass . 'lift'@+-- type Pass w m a = m (a, w -> w) -> m a
0.3/Control/Monad/Trans/Except.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif+ #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 #endif@@ -8,6 +12,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+# elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+# endif #endif ----------------------------------------------------------------------------- -- |@@ -57,6 +66,9 @@ import Control.Monad.IO.Class import Control.Monad.Signatures import Control.Monad.Trans.Class+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif #ifndef HASKELL98 import Control.Monad.Writer.Class@@ -117,22 +129,33 @@ -- first exception. newtype ExceptT e m a = ExceptT { runExceptT :: 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+ liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq 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+ liftCompare comp (ExceptT x) (ExceptT y) =+ liftCompare (liftCompare 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+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -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+ liftShowsPrec sp sl d (ExceptT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -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 -- | Map the unwrapped computation using the given function. --@@ -170,8 +193,12 @@ Right x -> return (Right (k x)) instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where- empty = mzero- (<|>) = mplus+ empty = ExceptT $ return (Left mempty)+ ExceptT mx <|> ExceptT my = ExceptT $ do+ ex <- mx+ case ex of+ Left e -> liftM (either (Left . mappend e) Right) my+ Right x -> return (Right x) instance (Monad m) => Monad (ExceptT e m) where return a = ExceptT $ return (Right a)@@ -191,15 +218,19 @@ Right x -> return (Right x) instance (MonadFix m) => MonadFix (ExceptT e m) where- mfix f = ExceptT $ mfix $ \ a -> runExceptT $ f $ case a of- Right x -> x- Left _ -> error "mfix ExceptT: Left"+ mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id))+ where bomb = error "mfix (ExceptT): inner computation returned Left value" instance MonadTrans (ExceptT e) where lift = ExceptT . liftM Right instance (MonadIO m) => MonadIO (ExceptT e m) where liftIO = lift . liftIO++#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (ExceptT e m) where+ mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b+#endif -- | Signal an exception value @e@. --
0.3/Data/Functor/Classes.hs view
@@ -1,26 +1,72 @@ {-# LANGUAGE CPP #-}+ #ifndef MIN_VERSION_transformers #define MIN_VERSION_transformers(a,b,c) 1 #endif++#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+# elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+# endif+# if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+# endif+#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+-- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : portable ----- Prelude classes, lifted to unary type constructors.+-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to+-- 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) => 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 base+-- classes is mechanical:+--+-- > 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- Eq1(..),- Ord1(..),- Read1(..),- Show1(..),+ -- ** For unary constructors+ Eq1(..), eq1,+ Ord1(..), compare1,+ Read1(..), readsPrec1,+ Show1(..), showsPrec1,+ -- ** For binary constructors+ Eq2(..), eq2,+ Ord2(..), compare2,+ Read2(..), readsPrec2,+ Show2(..), showsPrec2, -- * Helper functions+ -- $example readsData,+ readsUnaryWith,+ readsBinaryWith,+ showsUnaryWith,+ showsBinaryWith,+ -- ** Obsolete helpers readsUnary, readsUnary1, readsBinary1,@@ -29,6 +75,11 @@ showsBinary1, ) where +import Control.Applicative (Const(Const))+import Data.Functor.Identity (Identity(Identity))+import Data.Monoid (mappend)+import Text.Show (showListWith)+ import Control.Monad.Trans.Error import Control.Monad.Trans.Identity import Control.Monad.Trans.List@@ -37,73 +88,309 @@ 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+#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+# endif+#endif -- | Lifting of the 'Eq' class to unary type constructors. class Eq1 f where- eq1 :: (Eq a) => f a -> f a -> Bool+ -- | Lift an equality test through the type constructor.+ --+ -- The function will usually be applied to an equality function,+ -- but the more general type ensures that the implementation uses+ -- it to compare elements of the first container with elements of+ -- the second.+ liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool +-- | Lift the standard @('==')@ function through the type constructor.+eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool+eq1 = liftEq (==)+ -- | Lifting of the 'Ord' class to unary type constructors. class (Eq1 f) => Ord1 f where- compare1 :: (Ord a) => f a -> f a -> Ordering+ -- | Lift a 'compare' function through the type constructor.+ --+ -- The function will usually be applied to a comparison function,+ -- but the more general type ensures that the implementation uses+ -- it to compare elements of the first container with elements of+ -- the second.+ liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering +-- | Lift the standard 'compare' function through the type constructor.+compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering+compare1 = liftCompare compare+ -- | Lifting of the 'Read' class to unary type constructors. class Read1 f where- readsPrec1 :: (Read a) => Int -> ReadS (f a)+ -- | 'readsPrec' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument type.+ liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) + -- | 'readList' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument type.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]+ liftReadList rp rl = readListWith (liftReadsPrec rp rl 0)++-- | Read a list (using square brackets and commas), given a function+-- for reading elements.+readListWith :: ReadS a -> ReadS [a]+readListWith rp =+ readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])+ where+ readl s = [([],t) | ("]",t) <- lex s] +++ [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]+ readl' s = [([],t) | ("]",t) <- lex s] +++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]++-- | Lift the standard 'readsPrec' and 'readList' functions through the+-- type constructor.+readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)+readsPrec1 = liftReadsPrec readsPrec readList+ -- | Lifting of the 'Show' class to unary type constructors. class Show1 f where- showsPrec1 :: (Show a) => Int -> f a -> ShowS+ -- | 'showsPrec' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument type.+ liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+ Int -> f a -> ShowS + -- | 'showList' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument type.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+ [f a] -> ShowS+ liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)++-- | Lift the standard 'showsPrec' and 'showList' functions through the+-- type constructor.+showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS+showsPrec1 = liftShowsPrec showsPrec showList++-- | Lifting of the 'Eq' class to binary type constructors.+class Eq2 f where+ -- | Lift equality tests through the type constructor.+ --+ -- The function will usually be applied to equality functions,+ -- but the more general type ensures that the implementation uses+ -- them to compare elements of the first container with elements of+ -- the second.+ liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool++-- | Lift the standard @('==')@ function through the type constructor.+eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool+eq2 = liftEq2 (==) (==)++-- | Lifting of the 'Ord' class to binary type constructors.+class (Eq2 f) => Ord2 f where+ -- | Lift 'compare' functions through the type constructor.+ --+ -- The function will usually be applied to comparison functions,+ -- but the more general type ensures that the implementation uses+ -- them to compare elements of the first container with elements of+ -- the second.+ liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->+ f a c -> f b d -> Ordering++-- | Lift the standard 'compare' function through the type constructor.+compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering+compare2 = liftCompare2 compare compare++-- | Lifting of the 'Read' class to binary type constructors.+class Read2 f where+ -- | 'readsPrec' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument types.+ liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->+ (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)++ -- | 'readList' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument types.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->+ (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]+ liftReadList2 rp1 rl1 rp2 rl2 =+ readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0)++-- | Lift the standard 'readsPrec' function through the type constructor.+readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)+readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList++-- | Lifting of the 'Show' class to binary type constructors.+class Show2 f where+ -- | 'showsPrec' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument types.+ liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+ (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS++ -- | 'showList' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument types.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ 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)++-- | Lift the standard 'showsPrec' function through the type constructor.+showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS+showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList+ -- 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+ liftEq _ Nothing Nothing = True+ liftEq _ Nothing (Just _) = False+ liftEq _ (Just _) Nothing = False+ liftEq eq (Just x) (Just y) = eq x y -instance Eq1 [] where eq1 = (==)-instance Ord1 [] where compare1 = compare-instance Read1 [] where readsPrec1 = readsPrec-instance Show1 [] where showsPrec1 = showsPrec+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 (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 Read1 Maybe where+ liftReadsPrec rp _ d =+ readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])+ `mappend`+ readsData (readsUnaryWith rp "Just" Just) d -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 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+ liftReadsPrec _ rl _ = rl++instance Show1 [] where+ liftShowsPrec _ sl _ = sl++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+ liftReadsPrec2 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 Show2 (,) where+ liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =+ showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'++instance (Eq a) => Eq1 ((,) a) where+ liftEq = liftEq2 (==)++instance (Ord a) => Ord1 ((,) a) where+ liftCompare = liftCompare2 compare++instance (Read a) => Read1 ((,) a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++instance (Show a) => Show1 ((,) a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++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+ liftReadsPrec2 rp1 _ rp2 _ = readsData $+ readsUnaryWith rp1 "Left" Left `mappend`+ readsUnaryWith rp2 "Right" Right++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+ liftReadsPrec = liftReadsPrec2 readsPrec readList++instance (Show a) => Show1 (Either a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++-- Instances for other functors defined in the base package++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+ liftReadsPrec rp _ = readsData $+ readsUnaryWith rp "Identity" Identity++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+ liftReadsPrec2 rp _ _ _ = readsData $+ readsUnaryWith rp "Const" Const++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+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Show a) => Show1 (Const a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+ -- Building blocks -- | @'readsData' p d@ is a parser for datatypes where each alternative@@ -115,20 +402,54 @@ 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 liftReadsPrec" #-} 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 liftReadsPrec" #-} 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 liftReadsPrec" #-} readsBinary1 :: (Read1 f, Read1 g, Read a) => String -> (f a -> g a -> t) -> String -> ReadS t readsBinary1 name cons kw s =@@ -137,19 +458,22 @@ -- | @'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 liftShowsPrec" #-} 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 liftShowsPrec" #-} 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 liftShowsPrec" #-} showsBinary1 :: (Show1 f, Show1 g, Show a) => String -> Int -> f a -> g a -> ShowS showsBinary1 name d x y = showParen (d > 10) $@@ -157,232 +481,359 @@ 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 (Eq e, Eq1 m) => Eq1 (ErrorT e m) where+ liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq 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+ liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare 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+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl +instance (Show e, Show1 m) => Show1 (ErrorT e m) where+ liftShowsPrec sp sl d (ErrorT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl++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 d (ErrorT m) = showsUnary1 "ErrorT" d m+ showsPrec = showsPrec1 -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) => Eq1 (IdentityT f) where+ liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y -instance (Eq1 f, Eq a) => Eq (IdentityT f a) where- IdentityT x == IdentityT y = eq1 x y+instance (Ord1 f) => Ord1 (IdentityT f) where+ liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y -instance (Ord1 f, Ord a) => Ord (IdentityT f a) where- compare (IdentityT x) (IdentityT y) = compare1 x y+instance (Read1 f) => Read1 (IdentityT f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT -instance (Read1 f, Read a) => Read (IdentityT f a) where- readsPrec = readsData $ readsUnary1 "IdentityT" IdentityT+instance (Show1 f) => Show1 (IdentityT f) where+ liftShowsPrec sp sl d (IdentityT m) =+ showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m -instance (Show1 f, Show a) => Show (IdentityT f a) where- showsPrec d (IdentityT m) = showsUnary1 "IdentityT" d m+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 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) => Eq1 (ListT m) where+ liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y -instance (Eq1 m, Eq a) => Eq (ListT m a) where- ListT x == ListT y = eq1 x y+instance (Ord1 m) => Ord1 (ListT m) where+ liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y -instance (Ord1 m, Ord a) => Ord (ListT m a) where- compare (ListT x) (ListT y) = compare1 x y+instance (Read1 m) => Read1 (ListT m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -instance (Read1 m, Read a) => Read (ListT m a) where- readsPrec = readsData $ readsUnary1 "ListT" ListT+instance (Show1 m) => Show1 (ListT m) where+ liftShowsPrec sp sl d (ListT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -instance (Show1 m, Show a) => Show (ListT m a) where- showsPrec d (ListT m) = showsUnary1 "ListT" d m+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 -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) => Eq1 (MaybeT m) where+ liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y -instance (Eq1 m, Eq a) => Eq (MaybeT m a) where- MaybeT x == MaybeT y = eq1 x y+instance (Ord1 m) => Ord1 (MaybeT m) where+ liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y -instance (Ord1 m, Ord a) => Ord (MaybeT m a) where- compare (MaybeT x) (MaybeT y) = compare1 x y+instance (Read1 m) => Read1 (MaybeT m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -instance (Read1 m, Read a) => Read (MaybeT m a) where- readsPrec = readsData $ readsUnary1 "MaybeT" MaybeT+instance (Show1 m) => Show1 (MaybeT m) where+ liftShowsPrec sp sl d (MaybeT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -instance (Show1 m, Show a) => Show (MaybeT m a) where- showsPrec d (MaybeT m) = showsUnary1 "MaybeT" d m+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 -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) => Eq1 (Lazy.WriterT w m) where+ liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) =+ liftEq (liftEq2 eq (==)) m1 m2 -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) => Ord1 (Lazy.WriterT w m) where+ liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) =+ liftCompare (liftCompare2 comp compare) m1 m2 -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) => Read1 (Lazy.WriterT w m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT+ where+ rp' = liftReadsPrec2 rp rl readsPrec readList+ rl' = liftReadList2 rp rl readsPrec readList -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) => Show1 (Lazy.WriterT w m) where+ liftShowsPrec sp sl d (Lazy.WriterT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m+ where+ sp' = liftShowsPrec2 sp sl showsPrec showList+ sl' = liftShowList2 sp sl showsPrec showList +instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where+ (==) = eq1+instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where+ compare = compare1+instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where+ readsPrec = readsPrec1 instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where- showsPrec d (Lazy.WriterT m) = showsUnary1 "WriterT" d m+ showsPrec = showsPrec1 -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) => Eq1 (Strict.WriterT w m) where+ liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) =+ liftEq (liftEq2 eq (==)) m1 m2 -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) => Ord1 (Strict.WriterT w m) where+ liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) =+ liftCompare (liftCompare2 comp compare) m1 m2 -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) => Read1 (Strict.WriterT w m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT+ where+ rp' = liftReadsPrec2 rp rl readsPrec readList+ rl' = liftReadList2 rp rl readsPrec readList -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) => Show1 (Strict.WriterT w m) where+ liftShowsPrec sp sl d (Strict.WriterT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m+ where+ sp' = liftShowsPrec2 sp sl showsPrec showList+ sl' = liftShowList2 sp sl showsPrec showList +instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where+ (==) = eq1+instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where+ compare = compare1+instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where+ readsPrec = readsPrec1 instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where- showsPrec d (Strict.WriterT m) = showsUnary1 "WriterT" d m+ showsPrec = showsPrec1 -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 (Eq1 f, Eq1 g) => Eq1 (Compose f g) where+ liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y -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 (Ord1 f, Ord1 g) => Ord1 (Compose f g) where+ liftCompare comp (Compose x) (Compose y) =+ liftCompare (liftCompare comp) x 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 (Read1 f, Read1 g) => Read1 (Compose f g) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -instance (Functor f, Read1 f, Read1 g, Read a) => Read (Compose f g a) where- readsPrec = readsData $ readsUnary1 "Compose" (Compose . fmap getApply)+instance (Show1 f, Show1 g) => Show1 (Compose f g) where+ liftShowsPrec sp sl d (Compose x) =+ showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -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 (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where+ (==) = eq1+instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where+ compare = compare1+instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where+ readsPrec = readsPrec1+instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where+ showsPrec = showsPrec1 -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) => Eq1 (Product f g) where+ liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 -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) => Ord1 (Product f g) where+ liftCompare comp (Pair x1 y1) (Pair x2 y2) =+ liftCompare comp x1 x2 `mappend` liftCompare comp 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) => Read1 (Product f g) where+ liftReadsPrec rp rl = readsData $+ readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair -instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where- readsPrec = readsData $ readsBinary1 "Pair" Pair+instance (Show1 f, Show1 g) => Show1 (Product f g) where+ liftShowsPrec sp sl d (Pair x y) =+ showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y +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 d (Pair x y) = showsBinary1 "Pair" d x y+ showsPrec = showsPrec1 -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 Eq2 Constant where+ liftEq2 eq _ (Constant x) (Constant y) = eq x y+instance Ord2 Constant where+ liftCompare2 comp _ (Constant x) (Constant y) = comp x y+instance Read2 Constant where+ liftReadsPrec2 rp _ _ _ = readsData $+ readsUnaryWith rp "Constant" Constant+instance Show2 Constant where+ liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "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+instance (Eq a) => Eq1 (Constant a) where+ liftEq = liftEq2 (==)+instance (Ord a) => Ord1 (Constant a) where+ liftCompare = liftCompare2 compare+instance (Read a) => Read1 (Constant a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Show a) => Show1 (Constant a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList -instance Eq1 Identity where eq1 = (==)-instance Ord1 Identity where compare1 = compare-instance Read1 Identity where readsPrec1 = readsPrec-instance Show1 Identity where showsPrec1 = showsPrec+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+instance (Read a) => Read (Constant a b) where+ readsPrec = readsData $+ readsUnaryWith readsPrec "Constant" Constant+instance (Show a) => Show (Constant a b) where+ showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x --- Instances of Prelude classes+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 --- kludge to get type with the same instances as g a-newtype Apply g a = Apply (g a)+#if MIN_VERSION_transformers(0,3,0)+instance (Eq1 f) => Eq1 (Lift f) where+ liftEq eq (Pure x1) (Pure x2) = eq x1 x2+ liftEq _ (Pure _) (Other _) = False+ liftEq _ (Other _) (Pure _) = False+ liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 -getApply :: Apply g a -> g a-getApply (Apply x) = x+instance (Ord1 f) => Ord1 (Lift f) where+ liftCompare comp (Pure x1) (Pure x2) = comp x1 x2+ liftCompare _ (Pure _) (Other _) = LT+ liftCompare _ (Other _) (Pure _) = GT+ liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 -instance (Eq1 g, Eq a) => Eq (Apply g a) where- Apply x == Apply y = eq1 x y+instance (Read1 f) => Read1 (Lift f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith rp "Pure" Pure `mappend`+ readsUnaryWith (liftReadsPrec rp rl) "Other" Other -instance (Ord1 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = compare1 x y+instance (Show1 f) => Show1 (Lift f) where+ liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x+ liftShowsPrec sp sl d (Other y) =+ showsUnaryWith (liftShowsPrec sp sl) "Other" d y -instance (Read1 g, Read a) => Read (Apply g a) where- readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]+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 (Show1 g, Show a) => Show (Apply g a) where- showsPrec d (Apply x) = showsPrec1 d x+instance (Eq1 f) => Eq1 (Backwards f) where+ liftEq eq (Backwards x) (Backwards y) = liftEq eq x y -#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) => Ord1 (Backwards f) where+ liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y -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) => Read1 (Backwards f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards -instance (Read1 f, Read a) => Read (Lift f a) where- readsPrec = readsData $- readsUnary "Pure" Pure `mappend` readsUnary1 "Other" Other+instance (Show1 f) => Show1 (Backwards f) where+ liftShowsPrec sp sl d (Backwards x) =+ showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x -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, 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 -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 (Reverse f) where+ liftEq eq (Reverse x) (Reverse y) = liftEq eq x y -instance (Eq1 f, Eq a) => Eq (Backwards f a) where- Backwards x == Backwards y = eq1 x y+instance (Ord1 f) => Ord1 (Reverse f) where+ liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y -instance (Ord1 f, Ord a) => Ord (Backwards f a) where- compare (Backwards x) (Backwards y) = compare1 x y+instance (Read1 f) => Read1 (Reverse f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse -instance (Read1 f, Read a) => Read (Backwards f a) where- readsPrec = readsData $ readsUnary1 "Backwards" Backwards+instance (Show1 f) => Show1 (Reverse f) where+ liftShowsPrec sp sl d (Reverse x) =+ showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x -instance (Show1 f, Show a) => Show (Backwards f a) where- showsPrec d (Backwards x) = showsUnary1 "Backwards" d x+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+#endif -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+#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Eq1+deriving instance Typeable Eq2+deriving instance Typeable Ord1+deriving instance Typeable Ord2+deriving instance Typeable Read1+deriving instance Typeable Read2+deriving instance Typeable Show1+deriving instance Typeable Show2+# endif+#endif -instance (Eq1 f, Eq a) => Eq (Reverse f a) where- Reverse x == Reverse y = eq1 x y+{- $example+These functions can be used to assemble 'Read' and 'Show' instances for+new algebraic types. For example, given the definition -instance (Ord1 f, Ord a) => Ord (Reverse f a) where- compare (Reverse x) (Reverse y) = compare1 x y+> data T f a = Zero a | One (f a) | Two a (f a) -instance (Read1 f, Read a) => Read (Reverse f a) where- readsPrec = readsData $ readsUnary1 "Reverse" Reverse+a standard 'Read1' instance may be defined as -instance (Show1 f, Show a) => Show (Reverse f a) where- showsPrec d (Reverse x) = showsUnary1 "Reverse" d x+> instance (Read1 f) => Read1 (T f) where+> liftReadsPrec rp rl = readsData $+> readsUnaryWith rp "Zero" Zero `mappend`+> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend`+> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two -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+and the corresponding 'Show1' instance as++> instance (Show1 f) => Show1 (T f) where+> liftShowsPrec sp _ d (Zero x) =+> showsUnaryWith sp "Zero" d x+> liftShowsPrec sp sl d (One x) =+> showsUnaryWith (liftShowsPrec sp sl) "One" d x+> liftShowsPrec sp sl d (Two x y) =+> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y++-}
0.3/Data/Functor/Sum.hs view
@@ -1,3 +1,25 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+# endif+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+# endif+# if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+# endif+#endif -- | -- Module : Data.Functor.Sum -- Copyright : (c) Ross Paterson 2014@@ -19,32 +41,84 @@ import Data.Monoid (mappend) import Data.Traversable (Traversable(traverse)) +#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+# endif+# if __GLASGOW_HASKELL__ >= 708+import Data.Data+# endif+#endif+ -- | 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+#ifndef HASKELL98+# if __GLASGOW_HASKELL__ >= 702+deriving instance Generic (Sum f g a) -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 Generic1 (Sum f g) where+ type Rep1 (Sum f g) =+ D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f))+ :+: C1 MCInR (S1 NoSelector (Rec1 g)))+ from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f))))+ from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g))))+ to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f)+ to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) -instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where- readsPrec = readsData $- readsUnary1 "InL" InL `mappend` readsUnary1 "InR" InR+data MDSum+data MCInL+data MCInR -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 Datatype MDSum where+ datatypeName _ = "Sum"+ moduleName _ = "Data.Functor.Sum" -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 Constructor MCInL where+ conName _ = "InL"++instance Constructor MCInR where+ conName _ = "InR"+# endif++# if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Sum+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+ => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *))+# endif+#endif++instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where+ liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2+ liftEq _ (InL _) (InR _) = False+ liftEq _ (InR _) (InL _) = False+ liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2++instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where+ liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2+ liftCompare _ (InL _) (InR _) = LT+ liftCompare _ (InR _) (InL _) = GT+ liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2++instance (Read1 f, Read1 g) => Read1 (Sum f g) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend`+ readsUnaryWith (liftReadsPrec rp rl) "InR" InR++instance (Show1 f, Show1 g) => Show1 (Sum f g) where+ liftShowsPrec sp sl d (InL x) =+ showsUnaryWith (liftShowsPrec sp sl) "InL" d x+ liftShowsPrec sp sl d (InR y) =+ showsUnaryWith (liftShowsPrec sp sl) "InR" d y++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)
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2012 Edward Kmett+Copyright 2012-2015 Edward Kmett All rights reserved.
README.markdown view
@@ -1,7 +1,7 @@ transformers-compat =================== -[](http://travis-ci.org/ekmett/transformers-compat)+[](https://hackage.haskell.org/package/transformers-compat) [](http://travis-ci.org/ekmett/transformers-compat) This provides a thin compatibility shim on top of transformers-0.2 to add the types that were added in transformers-0.3.
+ src/Control/Monad/Trans/Instances.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++# if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Trustworthy #-}+# endif++# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+# endif++# if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DataKinds #-}+# endif+#endif++{-# OPTIONS_GHC -fno-warn-deprecations #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Trans.Instances+-- Copyright : (C) 2012-16 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Backports orphan instances which are not provided by other modules in+-- @transformers-compat@.+----------------------------------------------------------------------------+module Control.Monad.Trans.Instances () where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(a,b,c) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(a,b,c) 1+#endif++import Control.Applicative.Backwards (Backwards(..))+import Control.Applicative.Lift (Lift(..))+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.Trans.Cont (ContT(..))+import Control.Monad.Trans.Error (ErrorT(..))+import Control.Monad.Trans.Except ()+import Control.Monad.Trans.Identity (IdentityT(..))+import Control.Monad.Trans.List (ListT(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))+import Control.Monad.Trans.Reader (ReaderT(..))+import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..))+import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..))+import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))+import Data.Functor.Classes+import Data.Functor.Compose (Compose(..))+import Data.Functor.Constant (Constant(..))+import Data.Functor.Identity (Identity(..))+import Data.Functor.Product (Product(..))+import Data.Functor.Reverse (Reverse(..))+import Data.Functor.Sum ()++import Control.Applicative+import Control.Monad (MonadPlus(..))+import Control.Monad.Fix (MonadFix(..))+import Data.Foldable (Foldable(..))+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))+import Data.Traversable (Traversable(..))++#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(..))+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Bifunctor (Bifunctor(..))+#endif++#ifndef HASKELL98+import Data.Data (Data)+import Data.Typeable++# if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+# endif+#endif++#if !(MIN_VERSION_transformers(0,3,0))+-- Foldable/Traversable instances+instance (Foldable f) => Foldable (ErrorT e f) where+ foldMap f (ErrorT a) = foldMap (either (const mempty) f) a++instance (Traversable f) => Traversable (ErrorT e f) where+ traverse f (ErrorT a) =+ ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a++instance (Foldable f) => Foldable (IdentityT f) where+ foldMap f (IdentityT a) = foldMap f a++instance (Traversable f) => Traversable (IdentityT f) where+ traverse f (IdentityT a) = IdentityT <$> traverse f a++instance (Foldable f) => Foldable (ListT f) where+ foldMap f (ListT a) = foldMap (foldMap f) a++instance (Traversable f) => Traversable (ListT f) where+ traverse f (ListT a) = ListT <$> traverse (traverse f) a++instance (Foldable f) => Foldable (MaybeT f) where+ foldMap f (MaybeT a) = foldMap (foldMap f) a++instance (Traversable f) => Traversable (MaybeT f) where+ traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a++instance (Foldable f) => Foldable (Lazy.WriterT w f) where+ foldMap f = foldMap (f . fst) . Lazy.runWriterT++instance (Traversable f) => Traversable (Lazy.WriterT w f) where+ traverse f = fmap Lazy.WriterT . traverse f' . Lazy.runWriterT where+ f' (a, b) = fmap (\ c -> (c, b)) (f a)++instance (Foldable f) => Foldable (Strict.WriterT w f) where+ foldMap f = foldMap (f . fst) . Strict.runWriterT++instance (Traversable f) => Traversable (Strict.WriterT w f) where+ traverse f = fmap Strict.WriterT . traverse f' . Strict.runWriterT where+ f' (a, b) = fmap (\ c -> (c, b)) (f a)++-- MonadFix instances for IdentityT and MaybeT+instance (MonadFix m) => MonadFix (IdentityT m) where+ mfix f = IdentityT (mfix (runIdentityT . f))++instance (MonadFix m) => MonadFix (MaybeT m) where+ mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb))+ where bomb = error "mfix (MaybeT): inner computation returned Nothing"++# if !(MIN_VERSION_base(4,9,0))+-- Monad instances for Product+instance (Monad f, Monad g) => Monad (Product f g) where+ return x = Pair (return x) (return x)+ Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)+ where+ fstP (Pair a _) = a+ sndP (Pair _ b) = b++instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where+ mzero = Pair mzero mzero+ Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)++instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where+ mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))+ where+ fstP (Pair a _) = a+ sndP (Pair _ b) = b+# endif+#endif++#if !(MIN_VERSION_transformers(0,4,0))+-- Alternative IO instance+# if !(MIN_VERSION_base(4,9,0))+-- The version bounds of transformers prior to 0.4.0.0 should prevent this+-- instance from being compiled on base-4.8.0.0 and later, but we'll put+-- a check here just to be safe.+instance Alternative IO where+ empty = mzero+ (<|>) = mplus+# endif+#endif++#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,4,3))+-- transformers-0.4-specific Eq1, Ord1, Read1, and Show1 instances for Const+instance (Eq a) => Eq1 (Const a) where+ eq1 (Const x) (Const y) = x == y+instance (Ord a) => Ord1 (Const a) where+ compare1 (Const x) (Const y) = compare x y+instance (Read a) => Read1 (Const a) where+ readsPrec1 = readsData $ readsUnary "Const" Const+instance (Show a) => Show1 (Const a) where+ showsPrec1 d (Const x) = showsUnary "Const" d x+#endif++#if !(MIN_VERSION_transformers(0,5,0))+-- Monoid Constant instance+instance (Monoid a) => Monoid (Constant a b) where+ mempty = Constant mempty+ Constant x `mappend` Constant y = Constant (x `mappend` y)++-- MonadZip instances+# if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (IdentityT m) where+ mzipWith f (IdentityT a) (IdentityT b) = IdentityT (mzipWith f a b)++instance (MonadZip m) => MonadZip (ListT m) where+ mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b++instance (MonadZip m) => MonadZip (MaybeT m) where+ mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b++instance (MonadZip m) => MonadZip (ReaderT r m) where+ mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a ->+ mzipWith f (m a) (n a)++instance (Monoid w, MonadZip m) => MonadZip (Lazy.WriterT w m) where+ mzipWith f (Lazy.WriterT x) (Lazy.WriterT y) = Lazy.WriterT $+ mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y++instance (Monoid w, MonadZip m) => MonadZip (Strict.WriterT w m) where+ mzipWith f (Strict.WriterT x) (Strict.WriterT y) = Strict.WriterT $+ mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y++# if !(MIN_VERSION_base(4,8,0))+instance MonadZip Identity where+ mzipWith f (Identity x) (Identity y) = Identity (f x y)+ munzip (Identity (a, b)) = (Identity a, Identity b)+# endif++# if !(MIN_VERSION_base(4,9,0))+instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where+ mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)+# endif+# endif++# if MIN_VERSION_base(4,8,0)+-- Bifunctor Constant instance+instance Bifunctor Constant where+ first f (Constant x) = Constant (f x)+ second _ (Constant x) = Constant x+# else+-- Monoid Identity instance+instance (Monoid a) => Monoid (Identity a) where+ mempty = Identity mempty+ mappend (Identity x) (Identity y) = Identity (mappend x y)+# endif++# ifndef HASKELL98+-- Typeable instances+# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710+deriving instance Typeable Backwards+deriving instance Typeable Constant+deriving instance Typeable ContT+deriving instance Typeable ErrorT+deriving instance Typeable IdentityT+deriving instance Typeable Lift+deriving instance Typeable ListT+deriving instance Typeable MaybeT+deriving instance Typeable MonadTrans+deriving instance Typeable Lazy.RWST+deriving instance Typeable Strict.RWST+deriving instance Typeable ReaderT+deriving instance Typeable Reverse+deriving instance Typeable Lazy.StateT+deriving instance Typeable Strict.StateT++# if !(MIN_VERSION_base(4,9,0))+deriving instance Typeable Compose+deriving instance Typeable MonadIO+deriving instance Typeable Product+# endif+# endif++-- Identity instances+# if !(MIN_VERSION_base(4,8,0))+deriving instance Typeable1 Identity+deriving instance Data a => Data (Identity a)++# if __GLASGOW_HASKELL__ >= 702+instance Generic (Identity a) where+ type Rep (Identity a) = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity (Rec0 a)))+ from (Identity x) = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = Identity x++instance Generic1 Identity where+ type Rep1 Identity = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity Par1))+ from1 (Identity x) = M1 (M1 (M1 (Par1 x)))+ to1 (M1 (M1 (M1 x))) = Identity (unPar1 x)++data MDIdentity+data MCIdentity+data MSIdentity++instance Datatype MDIdentity where+ datatypeName _ = "Identity"+ moduleName _ = "Data.Functor.Identity"+# if __GLASGOW_HASKELL__ >= 708+ isNewtype _ = True+# endif++instance Constructor MCIdentity where+ conName _ = "Identity"+ conIsRecord _ = True++instance Selector MSIdentity where+ selName _ = "runIdentity"+# endif++# if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable 'Identity+# endif+# endif++# if !(MIN_VERSION_base(4,9,0))+# if __GLASGOW_HASKELL__ >= 702+-- Generic(1) instances for Compose+instance Generic (Compose f g a) where+ type Rep (Compose f g a) =+ D1 MDCompose+ (C1 MCCompose+ (S1 MSCompose (Rec0 (f (g a)))))+ from (Compose x) = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = Compose x++instance Functor f => Generic1 (Compose f g) where+ type Rep1 (Compose f g) =+ D1 MDCompose+ (C1 MCCompose+ (S1 MSCompose (f :.: Rec1 g)))+ from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x))))+ to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x))++data MDCompose+data MCCompose+data MSCompose++instance Datatype MDCompose where+ datatypeName _ = "Compose"+ moduleName _ = "Data.Functor.Compose"+# if __GLASGOW_HASKELL__ >= 708+ isNewtype _ = True+# endif++instance Constructor MCCompose where+ conName _ = "Compose"+ conIsRecord _ = True++instance Selector MSCompose where+ selName _ = "getCompose"++-- Generic(1) instances for Product+instance Generic (Product f g a) where+ type Rep (Product f g a) =+ D1 MDProduct+ (C1 MCPair+ (S1 NoSelector (Rec0 (f a)) :*: S1 NoSelector (Rec0 (g a))))+ from (Pair f g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))+ to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = Pair f g++instance Generic1 (Product f g) where+ type Rep1 (Product f g) =+ D1 MDProduct+ (C1 MCPair+ (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g)))+ from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))+ to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)++data MDProduct+data MCPair++instance Datatype MDProduct where+ datatypeName _ = "Product"+ moduleName _ = "Data.Functor.Product"++instance Constructor MCPair where+ conName _ = "Pair"+# endif++# if __GLASGOW_HASKELL__ >= 708+-- Data instances for Compose and Product+deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a)+ => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *))+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+ => Data (Product (f :: * -> *) (g :: * -> *) (a :: *))+# endif+# endif+# endif+#endif
transformers-compat.cabal view
@@ -1,6 +1,6 @@ name: transformers-compat category: Compatibility-version: 0.4.0.4+version: 0.5.0.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -9,11 +9,11 @@ stability: provisional homepage: http://github.com/ekmett/transformers-compat/ bug-reports: http://github.com/ekmett/transformers-compat/issues-copyright: Copyright (C) 2012 Edward A. Kmett+copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: A small compatibility shim exposing the new types from transformers 0.3 and 0.4 to older Haskell platforms. description: This package includes backported versions of types that were added- to transformers in transformers 0.3 and 0.4 for users who need strict+ to transformers in transformers 0.3, 0.4, and 0.5 for users who need strict transformers 0.2 or 0.3 compatibility to run on old versions of the platform, but also need those types. .@@ -39,15 +39,14 @@ location: git://github.com/ekmett/transformers-compat.git flag two- default: False- description: Use transformers 0.2. This must be selected manually and should- probably only be used on older GHCs around 7.0.x.+ default: True+ description: Use transformers 0.2. This will be selected by cabal picking the appropriate version. manual: True flag three default: False manual: True- description: Use transformers 0.3. This should toggle on/off automatically.+ description: Use transformers 0.3. This will be selected by cabal picking the appropriate version. flag mtl default: True@@ -58,6 +57,12 @@ build-depends: base >= 4.3 && < 5 + hs-source-dirs:+ src++ exposed-modules:+ Control.Monad.Trans.Instances+ other-modules: Paths_transformers_compat @@ -73,10 +78,12 @@ transformers >= 0.2 && < 0.3, mtl >= 2.0 && < 2.1 else- build-depends: transformers >= 0.4.1 && < 0.5+ build-depends: transformers >= 0.4.1 && < 0.6 if !flag(mtl) cpp-options: -DHASKELL98+ else+ build-depends: ghc-prim if flag(two) exposed-modules: