diff --git a/0.2/Control/Applicative/Backwards.hs b/0.2/Control/Applicative/Backwards.hs deleted file mode 100644 --- a/0.2/Control/Applicative/Backwards.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif --- | --- Module : Control.Applicative.Backwards --- Copyright : (c) Russell O'Connor 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Making functors with an 'Applicative' instance that performs actions --- in the reverse order. --- --- NB: This module is only included in @lens@ for backwards compatibility with --- @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.Traversable - -#ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -# endif -#endif - --- | The same functor, but with an 'Applicative' instance that performs --- actions in the reverse order. -newtype Backwards f a = Backwards { forwards :: f a } - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) --- Generic(1) instances for Backwards -instance Generic (Backwards f a) where - type Rep (Backwards f a) = D1 D1'Backwards (C1 C1_0'Backwards (S1 S1_0_0'Backwards (Rec0 (f a)))) - from (Backwards x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Backwards x - -instance Generic1 (Backwards f) where - type Rep1 (Backwards f) = D1 D1'Backwards (C1 C1_0'Backwards (S1 S1_0_0'Backwards (Rec1 f))) - from1 (Backwards x) = M1 (M1 (M1 (Rec1 x))) - to1 (M1 (M1 (M1 x))) = Backwards (unRec1 x) - -data D1'Backwards -data C1_0'Backwards -data S1_0_0'Backwards - -instance Datatype D1'Backwards where - datatypeName _ = "Backwards" - moduleName _ = "Control.Applicative.Backwards" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'Backwards where - conName _ = "Backwards" - conIsRecord _ = True - -instance Selector S1_0_0'Backwards where - selName _ = "forwards" -# endif -#endif - -instance (Eq1 f) => Eq1 (Backwards f) where - liftEq eq (Backwards x) (Backwards y) = liftEq eq x y - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Backwards f) where - liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y - {-# INLINE liftCompare #-} - -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) - {-# INLINE fmap #-} - x <$ Backwards a = Backwards (x <$ a) - {-# INLINE (<$) #-} - --- | Apply @f@-actions in the reverse order. -instance (Applicative f) => Applicative (Backwards f) where - pure a = Backwards (pure a) - {-# INLINE pure #-} - Backwards f <*> Backwards a = Backwards (a <**> f) - {-# INLINE (<*>) #-} -#if MIN_VERSION_base(4,10,0) - liftA2 f (Backwards m) (Backwards n) = Backwards $ liftA2 (flip f) n m - {-# INLINE liftA2 #-} -#endif -#if MIN_VERSION_base(4,2,0) - Backwards xs *> Backwards ys = Backwards (ys <* xs) - {-# INLINE (*>) #-} - Backwards ys <* Backwards xs = Backwards (xs *> ys) - {-# INLINE (<*) #-} -#endif - --- | Try alternatives in the same order as @f@. -instance (Alternative f) => Alternative (Backwards f) where - empty = Backwards empty - {-# INLINE empty #-} - Backwards x <|> Backwards y = Backwards (x <|> y) - {-# INLINE (<|>) #-} - --- | Derived instance. -instance (Foldable f) => Foldable (Backwards f) where - foldMap f (Backwards t) = foldMap f t - {-# INLINE foldMap #-} - foldr f z (Backwards t) = foldr f z t - {-# INLINE foldr #-} - foldl f z (Backwards t) = foldl f z t - {-# INLINE foldl #-} - foldr1 f (Backwards t) = foldr1 f t - {-# INLINE foldr1 #-} - foldl1 f (Backwards t) = foldl1 f t - {-# INLINE foldl1 #-} - --- | Derived instance. -instance (Traversable f) => Traversable (Backwards f) where - traverse f (Backwards t) = fmap Backwards (traverse f t) - {-# INLINE traverse #-} - sequenceA (Backwards t) = fmap Backwards (sequenceA t) - {-# INLINE sequenceA #-} diff --git a/0.2/Control/Applicative/Lift.hs b/0.2/Control/Applicative/Lift.hs deleted file mode 100644 --- a/0.2/Control/Applicative/Lift.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -#endif --- | --- Module : Control.Applicative.Lift --- Copyright : (c) Ross Paterson 2010 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Adding a new kind of pure computation to an applicative functor. --- --- NB: This module is only included in @lens@ for backwards compatibility with --- @transformers@ versions before 3.0. - -module Control.Applicative.Lift ( - -- * Lifting an applicative - Lift(..), - unLift, - mapLift, - elimLift, - -- * Collecting errors - Errors, - runErrors, - failure, - eitherToErrors - ) where - -import Data.Functor.Classes - -import Control.Applicative -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Constant -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) - -#ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -# endif -#endif - --- | Applicative functor formed by adding pure computations to a given --- applicative functor. -data Lift f a = Pure a | Other (f a) - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) --- Generic(1) instances for Lift -instance Generic (Lift f a) where - type Rep (Lift f a) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector (Rec0 a)) :+: C1 C1_1'Lift (S1 NoSelector (Rec0 (f a)))) - from (Pure x) = M1 (L1 (M1 (M1 (K1 x)))) - from (Other x) = M1 (R1 (M1 (M1 (K1 x)))) - to (M1 (L1 (M1 (M1 (K1 x))))) = Pure x - to (M1 (R1 (M1 (M1 (K1 x))))) = Other x - -instance Generic1 (Lift f) where - type Rep1 (Lift f) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector Par1) :+: C1 C1_1'Lift (S1 NoSelector (Rec1 f))) - from1 (Pure x) = M1 (L1 (M1 (M1 (Par1 x)))) - from1 (Other x) = M1 (R1 (M1 (M1 (Rec1 x)))) - to1 (M1 (L1 (M1 (M1 x)))) = Pure (unPar1 x) - to1 (M1 (R1 (M1 (M1 x)))) = Other (unRec1 x) - -instance Datatype D1'Lift where - datatypeName _ = "Lift" - moduleName _ = "Control.Applicative.Lift" - -instance Constructor C1_0'Lift where - conName _ = "Pure" - -instance Constructor C1_1'Lift where - conName _ = "Other" - -data D1'Lift -data C1_0'Lift -data C1_1'Lift -# endif -#endif - -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 - {-# INLINE liftEq #-} - -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 - {-# INLINE liftCompare #-} - -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) => 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, 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) - fmap f (Other y) = Other (fmap f y) - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (Lift f) where - foldMap f (Pure x) = f x - foldMap f (Other y) = foldMap f y - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (Lift f) where - traverse f (Pure x) = Pure <$> f x - traverse f (Other y) = Other <$> traverse f y - {-# INLINE traverse #-} - --- | A combination is 'Pure' only if both parts are. -instance (Applicative f) => Applicative (Lift f) where - pure = Pure - {-# INLINE pure #-} - Pure f <*> ax = f <$> ax - Other f <*> ax = Other (f <*> unLift ax) - {-# INLINE (<*>) #-} - --- | A combination is 'Pure' only either part is. -instance (Alternative f) => Alternative (Lift f) where - empty = Other empty - {-# INLINE empty #-} - Pure x <|> _ = Pure x - Other _ <|> Pure y = Pure y - Other x <|> Other y = Other (x <|> y) - {-# INLINE (<|>) #-} - --- | Projection to the other functor. -unLift :: (Applicative f) => Lift f a -> f a -unLift (Pure x) = pure x -unLift (Other e) = e -{-# INLINE unLift #-} - --- | 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) -{-# INLINE mapLift #-} - --- | Eliminator for 'Lift'. --- --- * @'elimLift' f g . 'pure' = f@ --- --- * @'elimLift' f g . 'Other' = g@ --- -elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r -elimLift f _ (Pure x) = f x -elimLift _ g (Other e) = g e -{-# INLINE elimLift #-} - --- | 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 'Control.Monad.Trans.Except.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 -{-# INLINE runErrors #-} - --- | Report an error. -failure :: e -> Errors e a -failure e = Other (Constant e) -{-# INLINE failure #-} - --- | Convert from 'Either' to 'Errors' (inverse of 'runErrors'). -eitherToErrors :: Either e a -> Errors e a -eitherToErrors = either failure Pure diff --git a/0.2/Data/Functor/Reverse.hs b/0.2/Data/Functor/Reverse.hs deleted file mode 100644 --- a/0.2/Data/Functor/Reverse.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif --- | --- Module : Data.Functor.Reverse --- Copyright : (c) Russell O'Connor 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Making functors whose elements are notionally in the reverse order --- from the original functor. --- --- /NB:/ Note this module is only included in @lens@ for backwards --- compatibility with older @containers@ versions. - -module Data.Functor.Reverse where - -import Control.Applicative.Backwards -import Data.Functor.Classes - -import Prelude hiding (foldr, foldr1, foldl, foldl1) -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Data.Foldable -import Data.Traversable -import Data.Monoid - -#ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -# endif -#endif - --- | The same functor, but with 'Foldable' and 'Traversable' instances --- that process the elements in the reverse order. -newtype Reverse f a = Reverse { getReverse :: f a } - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) --- Generic(1) instances for Reverse -instance Generic (Reverse f a) where - type Rep (Reverse f a) = D1 D1'Reverse (C1 C1_0'Reverse (S1 S1_0_0'Reverse (Rec0 (f a)))) - from (Reverse x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Reverse x - -instance Generic1 (Reverse f) where - type Rep1 (Reverse f) = D1 D1'Reverse (C1 C1_0'Reverse (S1 S1_0_0'Reverse (Rec1 f))) - from1 (Reverse x) = M1 (M1 (M1 (Rec1 x))) - to1 (M1 (M1 (M1 x))) = Reverse (unRec1 x) - -instance Datatype D1'Reverse where - datatypeName _ = "Reverse" - moduleName _ = "Data.Functor.Reverse" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'Reverse where - conName _ = "Reverse" - conIsRecord _ = True - -instance Selector S1_0_0'Reverse where - selName _ = "getReverse" - -data D1'Reverse -data C1_0'Reverse -data S1_0_0'Reverse -# endif -#endif - -instance (Eq1 f) => Eq1 (Reverse f) where - liftEq eq (Reverse x) (Reverse y) = liftEq eq x y - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Reverse f) where - liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y - {-# INLINE liftCompare #-} - -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) - {-# INLINE fmap #-} - --- | Derived instance. -instance (Applicative f) => Applicative (Reverse f) where - pure a = Reverse (pure a) - {-# INLINE pure #-} - Reverse f <*> Reverse a = Reverse (f <*> a) - {-# INLINE (<*>) #-} - --- | Derived instance. -instance (Alternative f) => Alternative (Reverse f) where - empty = Reverse empty - {-# INLINE empty #-} - Reverse x <|> Reverse y = Reverse (x <|> y) - {-# INLINE (<|>) #-} - --- | Derived instance. -instance (Monad m) => Monad (Reverse m) where - return a = Reverse (return a) - {-# INLINE return #-} - m >>= f = Reverse (getReverse m >>= getReverse . f) - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = Reverse (fail msg) - {-# INLINE fail #-} -#endif - --- | Derived instance. -instance (MonadPlus m) => MonadPlus (Reverse m) where - mzero = Reverse mzero - {-# INLINE mzero #-} - Reverse x `mplus` Reverse y = Reverse (x `mplus` y) - {-# INLINE mplus #-} - --- | Fold from right to left. -instance (Foldable f) => Foldable (Reverse f) where - foldMap f (Reverse t) = getDual (foldMap (Dual . f) t) - {-# INLINE foldMap #-} - foldr f z (Reverse t) = foldl (flip f) z t - {-# INLINE foldr #-} - foldl f z (Reverse t) = foldr (flip f) z t - {-# INLINE foldl #-} - foldr1 f (Reverse t) = foldl1 (flip f) t - {-# INLINE foldr1 #-} - foldl1 f (Reverse t) = foldr1 (flip f) t - {-# INLINE foldl1 #-} - --- | Traverse from right to left. -instance (Traversable f) => Traversable (Reverse f) where - traverse f (Reverse t) = - fmap Reverse . forwards $ traverse (Backwards . f) t - {-# INLINE traverse #-} - sequenceA (Reverse t) = - fmap Reverse . forwards $ sequenceA (fmap Backwards t) - {-# INLINE sequenceA #-} diff --git a/0.3/Control/Monad/Signatures.hs b/0.3/Control/Monad/Signatures.hs deleted file mode 100644 --- a/0.3/Control/Monad/Signatures.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Signatures --- Copyright : (c) Ross Paterson 2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- 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 ( - CallCC, Catch, Listen, Pass - ) where - --- | 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 diff --git a/0.3/Control/Monad/Trans/Except.hs b/0.3/Control/Monad/Trans/Except.hs deleted file mode 100644 --- a/0.3/Control/Monad/Trans/Except.hs +++ /dev/null @@ -1,418 +0,0 @@ -{-# 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 - -#ifndef HASKELL98 -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -# ifdef MTL -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# endif -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Except --- Copyright : (C) 2013 Ross Paterson --- (C) 2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- This monad transformer extends a monad with the ability throw exceptions. --- --- A sequence of actions terminates normally, producing a value, --- only if none of the actions in the sequence throws an exception. --- If one throws an exception, the rest of the sequence is skipped and --- the composite action exits with that exception. --- --- If the value of the exception is not required, the variant in --- "Control.Monad.Trans.Maybe" may be used instead. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Except ( - -- * The Except monad - Except, - except, - runExcept, - mapExcept, - withExcept, - -- * The ExceptT monad transformer - ExceptT(..), - mapExceptT, - withExceptT, - -- * Exception operations - throwE, - catchE, - handleE, - tryE, - finallyE, - -- * Lifting other operations - liftCallCC, - liftListen, - liftPass, - ) where - -import Control.Applicative -import Control.Monad -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix -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 - -#ifdef MTL -import Control.Monad.Writer.Class -import Control.Monad.State.Class -import Control.Monad.Reader.Class -import Control.Monad.Cont.Class -import Control.Monad.Error.Class -import Control.Monad.RWS.Class -#endif - -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Classes -import Data.Functor.Identity -import Data.Monoid -import Data.Traversable (Traversable(traverse)) - -#ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -# endif -#endif - --- | The parameterizable exception monad. --- --- Computations are either exceptions or normal values. --- --- The 'return' function returns a normal value, while @>>=@ exits --- on the first exception. -type Except e = ExceptT e Identity - --- | Constructor for computations in the exception monad. --- (The inverse of 'runExcept'). -except :: (Monad m) => Either e a -> ExceptT e m a -except m = ExceptT (return m) -{-# INLINE except #-} - --- | Extractor for computations in the exception monad. --- (The inverse of 'except'). -runExcept :: Except e a -> Either e a -runExcept (ExceptT m) = runIdentity m -{-# INLINE runExcept #-} - --- | Map the unwrapped computation using the given function. --- --- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@ -mapExcept :: (Either e a -> Either e' b) - -> Except e a - -> Except e' b -mapExcept f = mapExceptT (Identity . f . runIdentity) -{-# INLINE mapExcept #-} - --- | Transform any exceptions thrown by the computation using the given --- function (a specialization of 'withExceptT'). -withExcept :: (e -> e') -> Except e a -> Except e' a -withExcept = withExceptT -{-# INLINE withExcept #-} - --- | A monad transformer that adds exceptions to other monads. --- --- @ExceptT@ constructs a monad parameterized over two things: --- --- * e - The exception type. --- --- * m - The inner monad. --- --- The 'return' function yields a computation that produces the given --- value, while @>>=@ sequences two subcomputations, exiting on the --- first exception. -newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) --- Generic(1) instances for ExceptT -instance Generic (ExceptT e m a) where - type Rep (ExceptT e m a) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (Rec0 (m (Either e a))))) - from (ExceptT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = ExceptT x - -instance Functor m => Generic1 (ExceptT e m) where - type Rep1 (ExceptT e m) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (m :.: Rec1 (Either e)))) - from1 (ExceptT x) = M1 (M1 (M1 ((.) Comp1 (fmap Rec1) x))) - to1 (M1 (M1 (M1 x))) = ExceptT ((.) (fmap unRec1) unComp1 x) - -instance Datatype D1'ExceptT where - datatypeName _ = "ExceptT" - moduleName _ = "Control.Monad.Trans.Except" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'ExceptT where - conName _ = "ExceptT" - -data D1'ExceptT -data C1_0'ExceptT -# endif -#endif - -instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where - liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y - {-# INLINE liftEq #-} - -instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where - liftCompare comp (ExceptT x) (ExceptT y) = - liftCompare (liftCompare comp) x y - {-# INLINE liftCompare #-} - -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) => 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, 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. --- --- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ -mapExceptT :: (m (Either e a) -> n (Either e' b)) - -> ExceptT e m a - -> ExceptT e' n b -mapExceptT f m = ExceptT $ f (runExceptT m) -{-# INLINE mapExceptT #-} - --- | Transform any exceptions thrown by the computation using the --- given function. -withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a -withExceptT f = mapExceptT $ fmap $ either (Left . f) Right -{-# INLINE withExceptT #-} - -instance (Functor m) => Functor (ExceptT e m) where - fmap f = ExceptT . fmap (fmap f) . runExceptT - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (ExceptT e f) where - foldMap f (ExceptT a) = foldMap (either (const mempty) f) a - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (ExceptT e f) where - traverse f (ExceptT a) = - ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a - {-# INLINE traverse #-} - -instance (Functor m, Monad m) => Applicative (ExceptT e m) where - pure a = ExceptT $ return (Right a) - {-# INLINE pure #-} - ExceptT f <*> ExceptT v = ExceptT $ do - mf <- f - case mf of - Left e -> return (Left e) - Right k -> do - mv <- v - case mv of - Left e -> return (Left e) - Right x -> return (Right (k x)) - {-# INLINEABLE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where - empty = ExceptT $ return (Left mempty) - {-# INLINE empty #-} - 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) - {-# INLINEABLE (<|>) #-} - -instance (Monad m) => Monad (ExceptT e m) where - return a = ExceptT $ return (Right a) - {-# INLINE return #-} - m >>= k = ExceptT $ do - a <- runExceptT m - case a of - Left e -> return (Left e) - Right x -> runExceptT (k x) - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail = ExceptT . fail - {-# INLINE fail #-} -#endif - -instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where - fail = ExceptT . Fail.fail - {-# INLINE fail #-} - -instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where - mzero = ExceptT $ return (Left mempty) - {-# INLINE mzero #-} - ExceptT m `mplus` ExceptT n = ExceptT $ do - a <- m - case a of - Left e -> liftM (either (Left . mappend e) Right) n - Right x -> return (Right x) - {-# INLINEABLE mplus #-} - -instance (MonadFix m) => MonadFix (ExceptT e m) where - mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id)) - where bomb = error "mfix (ExceptT): inner computation returned Left value" - {-# INLINE mfix #-} - -instance MonadTrans (ExceptT e) where - lift = ExceptT . liftM Right - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (ExceptT e m) where - liftIO = lift . liftIO - {-# INLINE 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 - {-# INLINE mzipWith #-} -#endif - --- | Signal an exception value @e@. --- --- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@ --- --- * @'throwE' e >>= m = 'throwE' e@ -throwE :: (Monad m) => e -> ExceptT e m a -throwE = ExceptT . return . Left -{-# INLINE throwE #-} - --- | Handle an exception. --- --- * @'catchE' h ('lift' m) = 'lift' m@ --- --- * @'catchE' h ('throwE' e) = h e@ -catchE :: (Monad m) => - ExceptT e m a -- ^ the inner computation - -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner - -- computation - -> ExceptT e' m a -m `catchE` h = ExceptT $ do - a <- runExceptT m - case a of - Left l -> runExceptT (h l) - Right r -> return (Right r) -{-# INLINE catchE #-} - --- | The same as @'flip' 'catchE'@, which is useful in situations where --- the code for the handler is shorter. -handleE :: Monad m => (e -> ExceptT e' m a) -> ExceptT e m a -> ExceptT e' m a -handleE = flip catchE -{-# INLINE handleE #-} - --- | Similar to 'catchE', but returns an 'Either' result which is --- @('Right' a)@ if no exception was thown, or @('Left' ex)@ if an --- exception @ex@ was thrown. -tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a) -tryE m = catchE (liftM Right m) (return . Left) -{-# INLINE tryE #-} - --- | @'finallyE' a b@ executes computation @a@ followed by computation @b@, --- even if @a@ exits early by throwing an exception. In the latter case, --- the exception is re-thrown after @b@ has been executed. -finallyE :: Monad m => ExceptT e m a -> ExceptT e m () -> ExceptT e m a -finallyE m closer = do - res <- tryE m - closer - either throwE return res -{-# INLINE finallyE #-} - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b -liftCallCC callCC f = ExceptT $ - callCC $ \ c -> - runExceptT (f (\ a -> ExceptT $ c (Right a))) -{-# INLINE liftCallCC #-} - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a -liftListen listen = mapExceptT $ \ m -> do - (a, w) <- listen m - return $! fmap (\ r -> (r, w)) a -{-# INLINE liftListen #-} - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a -liftPass pass = mapExceptT $ \ m -> pass $ do - a <- m - return $! case a of - Left l -> (Left l, id) - Right (r, f) -> (Right r, f) -{-# INLINE liftPass #-} - --- incurring the mtl dependency for these avoids packages that need them introducing orphans. - -#ifdef MTL - -instance Monad m => MonadError e (ExceptT e m) where - throwError = throwE - catchError = catchE - -instance MonadWriter w m => MonadWriter w (ExceptT e m) where - tell = lift . tell - listen = liftListen listen - pass = liftPass pass -#if MIN_VERSION_mtl(2,1,0) - writer = lift . writer -#endif - -instance MonadState s m => MonadState s (ExceptT e m) where - get = lift get - put = lift . put -#if MIN_VERSION_mtl(2,1,0) - state = lift . state -#endif - -instance MonadReader r m => MonadReader r (ExceptT e m) where - ask = lift ask - local = mapExceptT . local -#if MIN_VERSION_mtl(2,1,0) - reader = lift . reader -#endif - -instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m) - -instance MonadCont m => MonadCont (ExceptT e m) where - callCC = liftCallCC callCC - -#endif diff --git a/0.3/Data/Functor/Classes.hs b/0.3/Data/Functor/Classes.hs deleted file mode 100644 --- a/0.3/Data/Functor/Classes.hs +++ /dev/null @@ -1,963 +0,0 @@ -{-# 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 : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- 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 - -- ** 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, - showsUnary, - showsUnary1, - showsBinary1, - ) where - -import Control.Applicative (Const(Const)) -import Data.Functor.Identity (Identity(Identity)) -import Data.Monoid (mappend) -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy(Proxy)) -#endif -import Text.Show (showListWith) - -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.Product -import Data.Complex (Complex (..)) - -#if MIN_VERSION_transformers(0,3,0) -import Control.Applicative.Lift -import Control.Applicative.Backwards -import Data.Functor.Reverse -#endif - - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -# endif -#endif - --- | Lifting of the 'Eq' class to unary type constructors. -class Eq1 f where - -- | 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 - -- | 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 - -- | '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 - -- | '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 - liftEq _ Nothing Nothing = True - liftEq _ Nothing (Just _) = False - liftEq _ (Just _) Nothing = False - liftEq eq (Just x) (Just y) = eq x y - -instance Ord1 Maybe where - liftCompare _ Nothing Nothing = EQ - liftCompare _ Nothing (Just _) = LT - liftCompare _ (Just _) Nothing = GT - liftCompare comp (Just x) (Just y) = comp x y - -instance Read1 Maybe where - liftReadsPrec rp _ d = - readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) - `mappend` - readsData (readsUnaryWith rp "Just" Just) d - -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 - -#if MIN_VERSION_base(4,7,0) -instance Eq1 Proxy where - liftEq _ _ _ = True - -instance Ord1 Proxy where - liftCompare _ _ _ = EQ - -instance Show1 Proxy where - liftShowsPrec _ _ _ _ = showString "Proxy" - -instance Read1 Proxy where - liftReadsPrec _ _ d = - readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) -#endif - --- 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] - --- | @'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 = - [(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@. -{-# 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 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) $ - showString name . showChar ' ' . showsPrec1 11 x . - showChar ' ' . showsPrec1 11 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) => Ord1 (ErrorT e m) where - liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y - -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 = showsPrec1 - -instance (Eq1 f) => Eq1 (IdentityT f) where - liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (IdentityT f) where - liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y - -instance (Read1 f) => Read1 (IdentityT f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT - -instance (Show1 f) => Show1 (IdentityT f) where - liftShowsPrec sp sl d (IdentityT m) = - showsUnaryWith (liftShowsPrec sp sl) "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 m) => Eq1 (ListT m) where - liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y - -instance (Ord1 m) => Ord1 (ListT m) where - liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) 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 (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 (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 (MaybeT m) where - liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y - -instance (Ord1 m) => Ord1 (MaybeT m) where - liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) 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 (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 (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 (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where - liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) = - liftEq (liftEq2 eq (==)) m1 m2 - -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 (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 (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 = showsPrec1 - -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 (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 (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 (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 = showsPrec1 - -instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where - liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y - -instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where - liftCompare comp (Compose x) (Compose y) = - liftCompare (liftCompare comp) x 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 (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 (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 (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 (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 (Read1 f, Read1 g) => Read1 (Product f g) where - liftReadsPrec rp rl = readsData $ - readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "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 = showsPrec1 - -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 - 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 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 - -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 - -#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 - -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) => Read1 (Lift f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith rp "Pure" Pure `mappend` - readsUnaryWith (liftReadsPrec rp rl) "Other" Other - -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, 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 (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 - -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 -#endif - -#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 - -#if MIN_VERSION_base(4,4,0) -instance Eq1 Complex where - liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v - -instance Read1 Complex where - liftReadsPrec rdP _ p s = readParen (p > complexPrec) (\s' -> do - (x, s'') <- rdP (complexPrec+1) s' - (":+", s''') <- lex s'' - (y, s'''') <- rdP (complexPrec+1) s''' - return (x :+ y, s'''')) s - where - complexPrec = 6 - -instance Show1 Complex where - liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $ - sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y - where - complexPrec = 6 -#endif - -instance Eq a => Eq2 ((,,) a) where - liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) = - u1 == v1 && - e1 x1 x2 && e2 y1 y2 - -instance Ord a => Ord2 ((,,) a) where - liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) = - compare u1 v1 `mappend` - comp1 x1 x2 `mappend` comp2 y1 y2 - -instance Read a => Read2 ((,,) a) where - liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> - [((e1,e2,e3), y) | ("(",s) <- lex r, - (e1,t) <- readsPrec 0 s, - (",",u) <- lex t, - (e2,v) <- rp1 0 u, - (",",w) <- lex v, - (e3,x) <- rp2 0 w, - (")",y) <- lex x] - -instance Show a => Show2 ((,,) a) where - liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2) - = showChar '(' . showsPrec 0 x1 - . showChar ',' . sp1 0 y1 - . showChar ',' . sp2 0 y2 - . showChar ')' - -instance (Eq a, Eq b) => Eq1 ((,,) a b) where - liftEq = liftEq2 (==) - -instance (Ord a, Ord b) => Ord1 ((,,) a b) where - liftCompare = liftCompare2 compare - -instance (Read a, Read b) => Read1 ((,,) a b) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a, Show b) => Show1 ((,,) a b) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance (Eq a, Eq b) => Eq2 ((,,,) a b) where - liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) = - u1 == v1 && - u2 == v2 && - e1 x1 x2 && e2 y1 y2 - -instance (Ord a, Ord b) => Ord2 ((,,,) a b) where - liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) = - compare u1 v1 `mappend` - compare u2 v2 `mappend` - comp1 x1 x2 `mappend` comp2 y1 y2 - -instance (Read a, Read b) => Read2 ((,,,) a b) where - liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> - [((e1,e2,e3,e4), s9) | ("(",s1) <- lex r, - (e1,s2) <- readsPrec 0 s1, - (",",s3) <- lex s2, - (e2,s4) <- readsPrec 0 s3, - (",",s5) <- lex s4, - (e3,s6) <- rp1 0 s5, - (",",s7) <- lex s6, - (e4,s8) <- rp2 0 s7, - (")",s9) <- lex s8] - -instance (Show a, Show b) => Show2 ((,,,) a b) where - liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2) - = showChar '(' . showsPrec 0 x1 - . showChar ',' . showsPrec 0 x2 - . showChar ',' . sp1 0 y1 - . showChar ',' . sp2 0 y2 - . showChar ')' - -instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where - liftEq = liftEq2 (==) - -instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where - liftCompare = liftCompare2 compare - -instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - - -{- $example -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 a (f a) - -a standard 'Read1' instance may be defined as - -> 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 - -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 - --} diff --git a/0.3/Data/Functor/Sum.hs b/0.3/Data/Functor/Sum.hs deleted file mode 100644 --- a/0.3/Data/Functor/Sum.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} -# endif -#endif --- | --- Module : Data.Functor.Sum --- Copyright : (c) Ross Paterson 2014 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Sums, lifted to functors. - -module Data.Functor.Sum ( - Sum(..), - ) where - -import Control.Applicative -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Classes -import Data.Monoid (mappend) -import Data.Traversable (Traversable(traverse)) - -#ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __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) - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) --- Generic(1) instances for Sum -instance Generic (Sum f g a) where - type Rep (Sum f g a) = - D1 MDSum (C1 MCInL (S1 NoSelector (Rec0 (f a))) - :+: C1 MCInR (S1 NoSelector (Rec0 (g a)))) - from (InL f) = M1 (L1 (M1 (M1 (K1 f)))) - from (InR g) = M1 (R1 (M1 (M1 (K1 g)))) - to (M1 (L1 (M1 (M1 (K1 f))))) = InL f - to (M1 (R1 (M1 (M1 (K1 g))))) = InR g - -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) - -data MDSum -data MCInL -data MCInR - -instance Datatype MDSum where - datatypeName _ = "Sum" - moduleName _ = "Data.Functor.Sum" - -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) - fmap f (InR y) = InR (fmap f y) - -instance (Foldable f, Foldable g) => Foldable (Sum f g) where - foldMap f (InL x) = foldMap f x - foldMap f (InR y) = foldMap f y - -instance (Traversable f, Traversable g) => Traversable (Sum f g) where - traverse f (InL x) = InL <$> traverse f x - traverse f (InR y) = InR <$> traverse f y diff --git a/0.5/Control/Monad/Trans/Accum.hs b/0.5/Control/Monad/Trans/Accum.hs --- a/0.5/Control/Monad/Trans/Accum.hs +++ b/0.5/Control/Monad/Trans/Accum.hs @@ -1,22 +1,12 @@ {-# LANGUAGE CPP #-} #ifndef HASKELL98 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DataKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} #endif ----------------------------------------------------------------------------- -- | @@ -78,20 +68,9 @@ import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.Signatures -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - #ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 import GHC.Generics -# endif #endif -- --------------------------------------------------------------------------- @@ -155,27 +134,7 @@ newtype AccumT w m a = AccumT (w -> m (a, w)) #ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 710 deriving instance Generic (AccumT w m a) -# elif __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) -instance Generic (AccumT w m a) where - type Rep (AccumT w m a) = D1 D1'AccumT (C1 C1_0'AccumT (S1 NoSelector (Rec0 (w -> m (a, w))))) - from (AccumT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = AccumT x - -instance Datatype D1'AccumT where - datatypeName _ = "AccumT" - moduleName _ = "Control.Monad.Trans.Accum" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'AccumT where - conName _ = "AccumT" - -data D1'AccumT -data C1_0'AccumT -# endif #endif -- | Unwrap an accumulation computation. @@ -230,10 +189,6 @@ {-# INLINE (<|>) #-} instance (Monoid w, Functor m, Monad m) => Monad (AccumT w m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = AccumT $ const $ return (a, mempty) - {-# INLINE return #-} -#endif m >>= k = AccumT $ \ w -> do ~(a, w') <- runAccumT m w ~(b, w'') <- runAccumT (k a) (w `mappend` w') @@ -267,10 +222,6 @@ instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where liftIO = lift . liftIO {-# INLINE liftIO #-} - -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable AccumT -#endif -- | @'look'@ is an action that fetches all the previously accumulated output. look :: (Monoid w, Monad m) => AccumT w m w diff --git a/0.5/Control/Monad/Trans/Select.hs b/0.5/Control/Monad/Trans/Select.hs --- a/0.5/Control/Monad/Trans/Select.hs +++ b/0.5/Control/Monad/Trans/Select.hs @@ -1,22 +1,12 @@ {-# LANGUAGE CPP #-} # ifndef HASKELL98 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DataKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} #endif ----------------------------------------------------------------------------- -- | @@ -62,16 +52,12 @@ import qualified Control.Monad.Fail as Fail import Data.Functor.Identity -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 +#if !defined(HASKELL98) import Data.Typeable #endif #ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 import GHC.Generics -# endif #endif -- | Selection monad. @@ -95,27 +81,7 @@ newtype SelectT r m a = SelectT ((a -> m r) -> m a) #ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 710 deriving instance Generic (SelectT r m a) -# elif __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) -instance Generic (SelectT r m a) where - type Rep (SelectT r m a) = D1 D1'SelectT (C1 C1_0'SelectT (S1 NoSelector (Rec0 ((a -> m r) -> m a)))) - from (SelectT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = SelectT x - -instance Datatype D1'SelectT where - datatypeName _ = "SelectT" - moduleName _ = "Control.Monad.Trans.Select" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'SelectT where - conName _ = "SelectT" - -data D1'SelectT -data C1_0'SelectT -# endif #endif -- | Runs a @SelectT@ computation with a function for evaluating answers @@ -163,10 +129,6 @@ {-# INLINE (<|>) #-} instance (Monad m) => Monad (SelectT r m) where -#if !(MIN_VERSION_base(4,8,0)) - return = lift . return - {-# INLINE return #-} -#endif SelectT g >>= f = SelectT $ \ k -> do let h x = runSelectT (f x) k y <- g ((>>= k) . h) @@ -190,10 +152,6 @@ instance (MonadIO m) => MonadIO (SelectT r m) where liftIO = lift . liftIO {-# INLINE liftIO #-} - -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable SelectT -#endif -- | Convert a selection computation to a continuation-passing computation. selectToContT :: (Monad m) => SelectT r m a -> ContT r m a diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,18 @@ +0.8 [2026.01.10] +---------------- +* Fix a bug where `liftShowsPrecDefault` would not evaluate empty data types + (i.e., data types whose generic representations use `V1`) properly. +* Drop support for pre-8.0 versions of GHC. As a consequence, + `transformers-compat` no longer supports pre-0.5 versions of `transformers`. +* Remove the `ghc8ShowBehavior` field of the `Options` data type in + `Data.Functor.Classes.Generic`. The machinery in this module now always + uses the behavior of `deriving Show` in GHC 8.0 or later. +* The `two`, `three`, and `four` `cabal` flags have been removed. +* The definitions of the `G{Eq,Ord,Read,Show}1` classes have been simplified + now that support for pre-0.5 versions of `transformers` has been dropped. + This is technically a breaking API change, albeit one that is unlikely to + affect most users. + 0.7.2 [2022.06.26] ------------------ * Add `Eq`, `Ord`, `Read`, and `Show` instances for `FunctorClassesDefault` in diff --git a/generics/Data/Functor/Classes/Generic.hs b/generics/Data/Functor/Classes/Generic.hs --- a/generics/Data/Functor/Classes/Generic.hs +++ b/generics/Data/Functor/Classes/Generic.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - {-| Module: Data.Functor.Classes.Generic Copyright: (C) 2015-2016 Edward Kmett, Ryan Scott @@ -16,21 +14,7 @@ Options(..) , defaultOptions , latestGHCOptions -#if defined(TRANSFORMERS_FOUR) -- * 'Eq1' - , eq1Default - , eq1Options - -- * 'Ord1' - , compare1Default - , compare1Options - -- * 'Read1' - , readsPrec1Default - , readsPrec1Options - -- * 'Show1' - , showsPrec1Default - , showsPrec1Options -#else - -- * 'Eq1' , liftEqDefault , liftEqOptions -- * 'Ord1' @@ -42,7 +26,6 @@ -- * 'Show1' , liftShowsPrecDefault , liftShowsPrecOptions -#endif -- * 'GenericFunctorClasses' , FunctorClassesDefault(..) -- * Example @@ -52,7 +35,6 @@ import qualified Data.Functor.Classes as C () import Data.Functor.Classes.Generic.Internal -#undef MIN_VERSION_transformers {- $example The most straightforward way to use the defaults in this module is to use @DerivingVia@ on GHC 8.6 or later. For example: @@ -71,12 +53,10 @@ @ If using an older version of GHC, then one can also define instances manually. -This is slightly trickier to accomplish since this module exports different -functions depending on which version of @transformers@ this library is built -against. Here is an example of how to define instances manually: +Here is an example: @ -{-# LANGUAGE CPP, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} import Data.Functor.Classes import Data.Functor.Classes.Generic @@ -85,31 +65,15 @@ data Pair a = Pair a a deriving Generic1 instance 'C.Eq1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.eq1' = 'eq1Default' -\#else 'C.liftEq' = 'liftEqDefault' -\#endif instance 'C.Ord1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.compare1' = 'compare1Default' -\#else 'C.liftCompare' = 'liftCompareDefault' -\#endif instance 'C.Read1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.readsPrec1' = 'readsPrec1Default' -\#else 'C.liftReadsPrec' = 'liftReadsPrecDefault' -\#endif instance 'C.Show1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.showsPrec1' = 'showsPrec1Default' -\#else 'C.liftShowsPrec' = 'liftShowsPrecDefault' -\#endif @ -} diff --git a/generics/Data/Functor/Classes/Generic/Internal.hs b/generics/Data/Functor/Classes/Generic/Internal.hs --- a/generics/Data/Functor/Classes/Generic/Internal.hs +++ b/generics/Data/Functor/Classes/Generic/Internal.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} @@ -11,12 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -#endif - #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-} #endif @@ -40,47 +35,23 @@ , defaultOptions , latestGHCOptions -- * 'Eq1' -#if defined(TRANSFORMERS_FOUR) - , eq1Default - , eq1Options -#else , liftEqDefault , liftEqOptions -#endif , GEq1(..) - , Eq1Args(..) -- * 'Ord1' -#if defined(TRANSFORMERS_FOUR) - , compare1Default - , compare1Options -#else , liftCompareDefault , liftCompareOptions -#endif , GOrd1(..) - , Ord1Args(..) -- * 'Read1' -#if defined(TRANSFORMERS_FOUR) - , readsPrec1Default - , readsPrec1Options -#else , liftReadsPrecDefault , liftReadsPrecOptions -#endif , GRead1(..) , GRead1Con(..) - , Read1Args(..) -- * 'Show1' -#if defined(TRANSFORMERS_FOUR) - , showsPrec1Default - , showsPrec1Options -#else , liftShowsPrecDefault , liftShowsPrecOptions -#endif , GShow1(..) , GShow1Con(..) - , Show1Args(..) -- * 'Eq' , eqDefault , GEq(..) @@ -97,8 +68,6 @@ -- * 'FunctorClassesDefault' , FunctorClassesDefault(..) -- * Miscellaneous types - , V4 - , NonV4 , ConType(..) , IsNullaryDataType(..) , IsNullaryCon(..) @@ -106,71 +75,32 @@ import Data.Char (isSymbol, ord) import Data.Functor.Classes -#ifdef GENERIC_DERIVING -import Generics.Deriving.Base hiding (prec) -#else +import GHC.Exts import GHC.Generics hiding (prec) -#endif -import GHC.Read (paren, parens) +import GHC.Read (expectP, list, paren, parens) import GHC.Show (appPrec, appPrec1, showSpace) import Text.ParserCombinators.ReadPrec import Text.Read (Read(..)) import Text.Read.Lex (Lexeme(..)) - -#if !defined(TRANSFORMERS_FOUR) -import GHC.Read (list) import Text.Show (showListWith) -#endif -#if MIN_VERSION_base(4,7,0) -import GHC.Read (expectP) -#else -import GHC.Read (lexP) -import Unsafe.Coerce (unsafeCoerce) -#endif -#if MIN_VERSION_base(4,7,0) || defined(GENERIC_DERIVING) -import GHC.Exts -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - ------------------------------------------------------------------------------- -- * Options ------------------------------------------------------------------------------- -- | Options that further configure how the functions in --- "Data.Functor.Classes.Generic" should behave. -newtype Options = Options - { ghc8ShowBehavior :: Bool - -- ^ If 'True', a default 'Show1' implementation will show hash signs - -- (@#@) when showing unlifted types. - } +-- "Data.Functor.Classes.Generic" should behave. Currently, the 'Options' have +-- no effect (but this may change in the future). +data Options = Options -- | Options that match the behavior of the installed version of GHC. defaultOptions :: Options defaultOptions = Options - { -#if __GLASGOW_HASKELL__ >= 800 - ghc8ShowBehavior = True -#else - ghc8ShowBehavior = False -#endif - } -- | Options that match the behavior of the most recent GHC release. latestGHCOptions :: Options -latestGHCOptions = Options { ghc8ShowBehavior = True } - --- | A type-level indicator that the @transformers-0.4@ version of a class method --- is being derived generically. -data V4 - --- | A type-level indicator that the non-@transformers-0.4@ version of a class --- method is being derived generically. -data NonV4 +latestGHCOptions = Options ------------------------------------------------------------------------------- -- * Eq @@ -211,15 +141,9 @@ instance (Eq1 f, Eq p) => GEq (Rec1 f p) where geq (Rec1 a) (Rec1 b) = eq1 a b -#if defined(TRANSFORMERS_FOUR) -instance (Functor f, Eq1 f, GEq (g p)) => GEq ((f :.: g) p) where - geq (Comp1 m) (Comp1 n) = eq1 (fmap Apply m) (fmap Apply n) -#else instance (Eq1 f, GEq (g p)) => GEq ((f :.: g) p) where geq (Comp1 m) (Comp1 n) = liftEq geq m n -#endif -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -- Unboxed types instance GEq (UAddr p) where geq = eqUAddr @@ -238,43 +162,21 @@ instance GEq (UWord p) where geq = eqUWord -#endif ------------------------------------------------------------------------------- -- * Eq1 ------------------------------------------------------------------------------- --- | An 'Eq1Args' value either stores an @Eq a@ dictionary (for the --- @transformers-0.4@ version of 'Eq1'), or it stores the function argument that --- checks the equality of occurrences of the type parameter (for the --- non-@transformers-0.4@ version of 'Eq1'). -data Eq1Args v a b where - V4Eq1Args :: Eq a => Eq1Args V4 a a - NonV4Eq1Args :: (a -> b -> Bool) -> Eq1Args NonV4 a b - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'eq1' implementation for 'Generic1' instances. -eq1Default :: (GEq1 V4 (Rep1 f), Generic1 f, Eq a) - => f a -> f a -> Bool -eq1Default = eq1Options defaultOptions - --- | Like 'eq1Default', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -eq1Options :: (GEq1 V4 (Rep1 f), Generic1 f, Eq a) - => Options -> f a -> f a -> Bool -eq1Options _ m n = gliftEq V4Eq1Args (from1 m) (from1 n) -#else -- | A sensible default 'liftEq' implementation for 'Generic1' instances. -liftEqDefault :: (GEq1 NonV4 (Rep1 f), Generic1 f) +liftEqDefault :: (GEq1 (Rep1 f), Generic1 f) => (a -> b -> Bool) -> f a -> f b -> Bool liftEqDefault = liftEqOptions defaultOptions -- | Like 'liftEqDefault', but with configurable 'Options'. Currently, -- the 'Options' have no effect (but this may change in the future). -liftEqOptions :: (GEq1 NonV4 (Rep1 f), Generic1 f) +liftEqOptions :: (GEq1 (Rep1 f), Generic1 f) => Options -> (a -> b -> Bool) -> f a -> f b -> Bool -liftEqOptions _ f m n = gliftEq (NonV4Eq1Args f) (from1 m) (from1 n) -#endif +liftEqOptions _ f m n = gliftEq f (from1 m) (from1 n) -- | Class of generic representation types that can lift equality through unary -- type constructors. @@ -282,68 +184,55 @@ #if __GLASGOW_HASKELL__ >= 806 (forall a. Eq a => GEq (t a)) => #endif - GEq1 v t where - gliftEq :: Eq1Args v a b -> t a -> t b -> Bool + GEq1 t where + gliftEq :: (a -> b -> Bool) -> t a -> t b -> Bool -instance Eq c => GEq1 v (K1 i c) where +instance Eq c => GEq1 (K1 i c) where gliftEq _ (K1 c) (K1 d) = c == d -instance (GEq1 v f, GEq1 v g) => GEq1 v (f :*: g) where +instance (GEq1 f, GEq1 g) => GEq1 (f :*: g) where gliftEq f (a :*: b) (c :*: d) = gliftEq f a c && gliftEq f b d -instance (GEq1 v f, GEq1 v g) => GEq1 v (f :+: g) where +instance (GEq1 f, GEq1 g) => GEq1 (f :+: g) where gliftEq f (L1 a) (L1 c) = gliftEq f a c gliftEq f (R1 b) (R1 d) = gliftEq f b d gliftEq _ _ _ = False -instance GEq1 v f => GEq1 v (M1 i c f) where +instance GEq1 f => GEq1 (M1 i c f) where gliftEq f (M1 a) (M1 b) = gliftEq f a b -instance GEq1 v U1 where +instance GEq1 U1 where gliftEq _ U1 U1 = True -instance GEq1 v V1 where +instance GEq1 V1 where gliftEq _ _ _ = True -#if defined(TRANSFORMERS_FOUR) -instance GEq1 V4 Par1 where - gliftEq V4Eq1Args (Par1 a) (Par1 b) = a == b - -instance Eq1 f => GEq1 V4 (Rec1 f) where - gliftEq V4Eq1Args (Rec1 a) (Rec1 b) = eq1 a b - -instance (Functor f, Eq1 f, GEq1 V4 g) => GEq1 V4 (f :.: g) where - gliftEq V4Eq1Args (Comp1 m) (Comp1 n) = eq1 (fmap Apply1 m) (fmap Apply1 n) -#else -instance GEq1 NonV4 Par1 where - gliftEq (NonV4Eq1Args f) (Par1 a) (Par1 b) = f a b +instance GEq1 Par1 where + gliftEq f (Par1 a) (Par1 b) = f a b -instance Eq1 f => GEq1 NonV4 (Rec1 f) where - gliftEq (NonV4Eq1Args f) (Rec1 a) (Rec1 b) = liftEq f a b +instance Eq1 f => GEq1 (Rec1 f) where + gliftEq f (Rec1 a) (Rec1 b) = liftEq f a b -instance (Eq1 f, GEq1 NonV4 g) => GEq1 NonV4 (f :.: g) where - gliftEq (NonV4Eq1Args f) (Comp1 m) (Comp1 n) = - liftEq (gliftEq (NonV4Eq1Args f)) m n -#endif +instance (Eq1 f, GEq1 g) => GEq1 (f :.: g) where + gliftEq f (Comp1 m) (Comp1 n) = liftEq (gliftEq f) m n -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -- Unboxed types -instance GEq1 v UAddr where +instance GEq1 UAddr where gliftEq _ = eqUAddr -instance GEq1 v UChar where +instance GEq1 UChar where gliftEq _ = eqUChar -instance GEq1 v UDouble where +instance GEq1 UDouble where gliftEq _ = eqUDouble -instance GEq1 v UFloat where +instance GEq1 UFloat where gliftEq _ = eqUFloat -instance GEq1 v UInt where +instance GEq1 UInt where gliftEq _ = eqUInt -instance GEq1 v UWord where +instance GEq1 UWord where gliftEq _ = eqUWord eqUAddr :: UAddr p -> UAddr q -> Bool @@ -363,7 +252,6 @@ eqUWord :: UWord p -> UWord q -> Bool eqUWord (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) -#endif ------------------------------------------------------------------------------- -- * Ord @@ -405,15 +293,9 @@ instance (Ord1 f, Ord p) => GOrd (Rec1 f p) where gcompare (Rec1 a) (Rec1 b) = compare1 a b -#if defined(TRANSFORMERS_FOUR) -instance (Functor f, Ord1 f, GOrd (g p)) => GOrd ((f :.: g) p) where - gcompare (Comp1 m) (Comp1 n) = compare1 (fmap Apply m) (fmap Apply n) -#else instance (Ord1 f, GOrd (g p)) => GOrd ((f :.: g) p) where gcompare (Comp1 m) (Comp1 n) = liftCompare gcompare m n -#endif -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -- Unboxed types instance GOrd (UAddr p) where gcompare = compareUAddr @@ -432,115 +314,79 @@ instance GOrd (UWord p) where gcompare = compareUWord -#endif ------------------------------------------------------------------------------- -- * Ord1 ------------------------------------------------------------------------------- --- | An 'Ord1Args' value either stores an @Ord a@ dictionary (for the --- @transformers-0.4@ version of 'Ord1'), or it stores the function argument that --- compares occurrences of the type parameter (for the non-@transformers-0.4@ --- version of 'Ord1'). -data Ord1Args v a b where - V4Ord1Args :: Ord a => Ord1Args V4 a a - NonV4Ord1Args :: (a -> b -> Ordering) -> Ord1Args NonV4 a b - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'compare1' implementation for 'Generic1' instances. -compare1Default :: (GOrd1 V4 (Rep1 f), Generic1 f, Ord a) - => f a -> f a -> Ordering -compare1Default = compare1Options defaultOptions - --- | Like 'compare1Default', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -compare1Options :: (GOrd1 V4 (Rep1 f), Generic1 f, Ord a) - => Options -> f a -> f a -> Ordering -compare1Options _ m n = gliftCompare V4Ord1Args (from1 m) (from1 n) -#else -- | A sensible default 'liftCompare' implementation for 'Generic1' instances. -liftCompareDefault :: (GOrd1 NonV4 (Rep1 f), Generic1 f) +liftCompareDefault :: (GOrd1 (Rep1 f), Generic1 f) => (a -> b -> Ordering) -> f a -> f b -> Ordering liftCompareDefault = liftCompareOptions defaultOptions -- | Like 'liftCompareDefault', but with configurable 'Options'. Currently, -- the 'Options' have no effect (but this may change in the future). -liftCompareOptions :: (GOrd1 NonV4 (Rep1 f), Generic1 f) +liftCompareOptions :: (GOrd1 (Rep1 f), Generic1 f) => Options -> (a -> b -> Ordering) -> f a -> f b -> Ordering -liftCompareOptions _ f m n = gliftCompare (NonV4Ord1Args f) (from1 m) (from1 n) -#endif +liftCompareOptions _ f m n = gliftCompare f (from1 m) (from1 n) -- | Class of generic representation types that can lift a total order through -- unary type constructors. -class ( GEq1 v t +class ( GEq1 t #if __GLASGOW_HASKELL__ >= 806 , forall a. Ord a => GOrd (t a) #endif - ) => GOrd1 v t where - gliftCompare :: Ord1Args v a b -> t a -> t b -> Ordering + ) => GOrd1 t where + gliftCompare :: (a -> b -> Ordering) -> t a -> t b -> Ordering -instance Ord c => GOrd1 v (K1 i c) where +instance Ord c => GOrd1 (K1 i c) where gliftCompare _ (K1 c) (K1 d) = compare c d -instance (GOrd1 v f, GOrd1 v g) => GOrd1 v (f :*: g) where +instance (GOrd1 f, GOrd1 g) => GOrd1 (f :*: g) where gliftCompare f (a :*: b) (c :*: d) = gliftCompare f a c `mappend` gliftCompare f b d -instance (GOrd1 v f, GOrd1 v g) => GOrd1 v (f :+: g) where +instance (GOrd1 f, GOrd1 g) => GOrd1 (f :+: g) where gliftCompare f (L1 a) (L1 c) = gliftCompare f a c gliftCompare _ L1{} R1{} = LT gliftCompare _ R1{} L1{} = GT gliftCompare f (R1 b) (R1 d) = gliftCompare f b d -instance GOrd1 v f => GOrd1 v (M1 i c f) where +instance GOrd1 f => GOrd1 (M1 i c f) where gliftCompare f (M1 a) (M1 b) = gliftCompare f a b -instance GOrd1 v U1 where +instance GOrd1 U1 where gliftCompare _ U1 U1 = EQ -instance GOrd1 v V1 where +instance GOrd1 V1 where gliftCompare _ _ _ = EQ -#if defined(TRANSFORMERS_FOUR) -instance GOrd1 V4 Par1 where - gliftCompare V4Ord1Args (Par1 a) (Par1 b) = compare a b - -instance Ord1 f => GOrd1 V4 (Rec1 f) where - gliftCompare V4Ord1Args (Rec1 a) (Rec1 b) = compare1 a b - -instance (Functor f, Ord1 f, GOrd1 V4 g) => GOrd1 V4 (f :.: g) where - gliftCompare V4Ord1Args (Comp1 m) (Comp1 n) = - compare1 (fmap Apply1 m) (fmap Apply1 n) -#else -instance GOrd1 NonV4 Par1 where - gliftCompare (NonV4Ord1Args f) (Par1 a) (Par1 b) = f a b +instance GOrd1 Par1 where + gliftCompare f (Par1 a) (Par1 b) = f a b -instance Ord1 f => GOrd1 NonV4 (Rec1 f) where - gliftCompare (NonV4Ord1Args f) (Rec1 a) (Rec1 b) = liftCompare f a b +instance Ord1 f => GOrd1 (Rec1 f) where + gliftCompare f (Rec1 a) (Rec1 b) = liftCompare f a b -instance (Ord1 f, GOrd1 NonV4 g) => GOrd1 NonV4 (f :.: g) where - gliftCompare (NonV4Ord1Args f) (Comp1 m) (Comp1 n) = - liftCompare (gliftCompare (NonV4Ord1Args f)) m n -#endif +instance (Ord1 f, GOrd1 g) => GOrd1 (f :.: g) where + gliftCompare f (Comp1 m) (Comp1 n) = liftCompare (gliftCompare f) m n -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -- Unboxed types -instance GOrd1 v UAddr where +instance GOrd1 UAddr where gliftCompare _ = compareUAddr -instance GOrd1 v UChar where +instance GOrd1 UChar where gliftCompare _ = compareUChar -instance GOrd1 v UDouble where +instance GOrd1 UDouble where gliftCompare _ = compareUDouble -instance GOrd1 v UFloat where +instance GOrd1 UFloat where gliftCompare _ = compareUFloat -instance GOrd1 v UInt where +instance GOrd1 UInt where gliftCompare _ = compareUInt -instance GOrd1 v UWord where +instance GOrd1 UWord where gliftCompare _ = compareUWord compareUAddr :: UAddr p -> UAddr q -> Ordering @@ -561,15 +407,10 @@ compareUWord :: UWord p -> UWord q -> Ordering compareUWord (UWord w1) (UWord w2) = primCompare (eqWord# w1 w2) (leWord# w1 w2) -# if __GLASGOW_HASKELL__ >= 708 primCompare :: Int# -> Int# -> Ordering -# else -primCompare :: Bool -> Bool -> Ordering -# endif primCompare eq le = if isTrue# eq then EQ else if isTrue# le then LT else GT -#endif ------------------------------------------------------------------------------- -- * Read @@ -616,18 +457,7 @@ instance Read p => GReadCon (Par1 p) where greadPrecCon _ = coercePar1 readPrec -#if defined(TRANSFORMERS_FOUR) instance (Read1 f, Read p) => GReadCon (Rec1 f p) where - greadPrecCon _ = coerceRec1 $ readS_to_Prec readsPrec1 - -instance (Functor f, Read1 f, GReadCon (g p)) => GReadCon ((f :.: g) p) where - greadPrecCon _ = - coerceComp1 $ fmap (fmap getApply) $ readS_to_Prec crp1 - where - crp1 :: Int -> ReadS (f (Apply g p)) - crp1 = readsPrec1 -#else -instance (Read1 f, Read p) => GReadCon (Rec1 f p) where greadPrecCon _ = coerceRec1 $ readS_to_Prec $ liftReadsPrec (readPrec_to_S readPrec) (readPrec_to_S readListPrec 0) @@ -637,57 +467,24 @@ (readPrec_to_S (list grpc) 0) where grpc = greadPrecCon t -#endif ------------------------------------------------------------------------------- -- * Read1 ------------------------------------------------------------------------------- --- | A 'Read1Args' value either stores a @Read a@ dictionary (for the --- @transformers-0.4@ version of 'Read1'), or it stores the two function arguments --- that parse occurrences of the type parameter (for the non-@transformers-0.4@ --- version of 'Read1'). -data Read1Args v a where - V4Read1Args :: Read a => Read1Args V4 a - NonV4Read1Args :: ReadPrec a -> ReadPrec [a] -> Read1Args NonV4 a - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'readsPrec1' implementation for 'Generic1' instances. -readsPrec1Default :: (GRead1 V4 (Rep1 f), Generic1 f, Read a) - => Int -> ReadS (f a) -readsPrec1Default = readsPrec1Options defaultOptions - --- | Like 'readsPrec1Default', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -readsPrec1Options :: (GRead1 V4 (Rep1 f), Generic1 f, Read a) - => Options -> Int -> ReadS (f a) -readsPrec1Options _ p = - readPrec_to_S (fmap to1 $ gliftReadPrec V4Read1Args) p -#else -- | A sensible default 'liftReadsPrec' implementation for 'Generic1' instances. -liftReadsPrecDefault :: (GRead1 NonV4 (Rep1 f), Generic1 f) +liftReadsPrecDefault :: (GRead1 (Rep1 f), Generic1 f) => (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) liftReadsPrecDefault = liftReadsPrecOptions defaultOptions -- | Like 'liftReadsPrecDefault', but with configurable 'Options'. Currently, -- the 'Options' have no effect (but this may change in the future). -liftReadsPrecOptions :: (GRead1 NonV4 (Rep1 f), Generic1 f) +liftReadsPrecOptions :: (GRead1 (Rep1 f), Generic1 f) => Options -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) liftReadsPrecOptions _ rp rl p = readPrec_to_S (fmap to1 $ gliftReadPrec - (NonV4Read1Args (readS_to_Prec rp) - (readS_to_Prec (const rl)))) p -#endif - -#if !(MIN_VERSION_base(4,7,0)) -coerce :: a -> b -coerce = unsafeCoerce - -expectP :: Lexeme -> ReadPrec () -expectP lexeme = do - thing <- lexP - if thing == lexeme then return () else pfail -#endif + (readS_to_Prec rp) + (readS_to_Prec (const rl))) p coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p) coerceM1 = coerce @@ -734,11 +531,11 @@ #if __GLASGOW_HASKELL__ >= 806 (forall a. Read a => GRead (f a)) => #endif - GRead1 v f where - gliftReadPrec :: Read1Args v a -> ReadPrec (f a) + GRead1 f where + gliftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a) -instance (GRead1 v f, IsNullaryDataType f) => GRead1 v (D1 d f) where - gliftReadPrec = d1ReadPrec . gliftReadPrec +instance (GRead1 f, IsNullaryDataType f) => GRead1 (D1 d f) where + gliftReadPrec rp rl = d1ReadPrec $ gliftReadPrec rp rl d1ReadPrec :: forall d f p. IsNullaryDataType f => ReadPrec (f p) -> ReadPrec (D1 d f p) @@ -752,15 +549,15 @@ then id else parens -instance GRead1 v V1 where - gliftReadPrec _ = pfail +instance GRead1 V1 where + gliftReadPrec _ _ = pfail -instance (GRead1 v f, GRead1 v g) => GRead1 v (f :+: g) where - gliftReadPrec ras = - fmap L1 (gliftReadPrec ras) +++ fmap R1 (gliftReadPrec ras) +instance (GRead1 f, GRead1 g) => GRead1 (f :+: g) where + gliftReadPrec rp rl = + fmap L1 (gliftReadPrec rp rl) +++ fmap R1 (gliftReadPrec rp rl) -instance (Constructor c, GRead1Con v f, IsNullaryCon f) => GRead1 v (C1 c f) where - gliftReadPrec ras = c1ReadPrec $ \t -> gliftReadPrecCon t ras +instance (Constructor c, GRead1Con f, IsNullaryCon f) => GRead1 (C1 c f) where + gliftReadPrec rp rl = c1ReadPrec $ \t -> gliftReadPrecCon t rp rl c1ReadPrec :: forall c f p. (Constructor c, IsNullaryCon f) => (ConType -> ReadPrec (f p)) -> ReadPrec (C1 c f p) @@ -821,17 +618,17 @@ #if __GLASGOW_HASKELL__ >= 806 (forall a. Read a => GReadCon (f a)) => #endif - GRead1Con v f where - gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec (f a) + GRead1Con f where + gliftReadPrecCon :: ConType -> ReadPrec a -> ReadPrec [a] -> ReadPrec (f a) -instance GRead1Con v U1 where - gliftReadPrecCon _ _ = return U1 +instance GRead1Con U1 where + gliftReadPrecCon _ _ _ = return U1 -instance Read c => GRead1Con v (K1 i c) where - gliftReadPrecCon _ _ = coerceK1 readPrec +instance Read c => GRead1Con (K1 i c) where + gliftReadPrecCon _ _ _ = coerceK1 readPrec -instance (Selector s, GRead1Con v f) => GRead1Con v (S1 s f) where - gliftReadPrecCon t = s1ReadPrec . gliftReadPrecCon t +instance (Selector s, GRead1Con f) => GRead1Con (S1 s f) where + gliftReadPrecCon t rp rl = s1ReadPrec $ gliftReadPrecCon t rp rl s1ReadPrec :: forall s f p. Selector s => ReadPrec (f p) -> ReadPrec (S1 s f p) @@ -851,9 +648,9 @@ | otherwise = identHLexemes lbl -instance (GRead1Con v f, GRead1Con v g) => GRead1Con v (f :*: g) where - gliftReadPrecCon t ras = - productReadPrec t (gliftReadPrecCon t ras) (gliftReadPrecCon t ras) +instance (GRead1Con f, GRead1Con g) => GRead1Con (f :*: g) where + gliftReadPrecCon t rp rl = + productReadPrec t (gliftReadPrecCon t rp rl) (gliftReadPrecCon t rp rl) productReadPrec :: ConType -> ReadPrec (f p) -> ReadPrec (g p) -> ReadPrec ((f :*: g) p) productReadPrec t rpf rpg = do @@ -872,34 +669,19 @@ else mapM_ expectP $ [Punc "`"] ++ identHLexemes o ++ [Punc "`"] -#if defined(TRANSFORMERS_FOUR) -instance GRead1Con V4 Par1 where - gliftReadPrecCon _ V4Read1Args = coercePar1 readPrec - -instance Read1 f => GRead1Con V4 (Rec1 f) where - gliftReadPrecCon _ V4Read1Args = coerceRec1 $ readS_to_Prec readsPrec1 - -instance (Functor f, Read1 f, GRead1Con V4 g) => GRead1Con V4 (f :.: g) where - gliftReadPrecCon _ (V4Read1Args :: Read1Args V4 p) = - coerceComp1 $ fmap (fmap getApply1) $ readS_to_Prec crp1 - where - crp1 :: Int -> ReadS (f (Apply1 g p)) - crp1 = readsPrec1 -#else -instance GRead1Con NonV4 Par1 where - gliftReadPrecCon _ (NonV4Read1Args rp _) = coercePar1 rp +instance GRead1Con Par1 where + gliftReadPrecCon _ rp _ = coercePar1 rp -instance Read1 f => GRead1Con NonV4 (Rec1 f) where - gliftReadPrecCon _ (NonV4Read1Args rp rl) = coerceRec1 $ readS_to_Prec $ +instance Read1 f => GRead1Con (Rec1 f) where + gliftReadPrecCon _ rp rl = coerceRec1 $ readS_to_Prec $ liftReadsPrec (readPrec_to_S rp) (readPrec_to_S rl 0) -instance (Read1 f, GRead1Con NonV4 g) => GRead1Con NonV4 (f :.: g) where - gliftReadPrecCon t (NonV4Read1Args rp rl) = coerceComp1 $ readS_to_Prec $ +instance (Read1 f, GRead1Con g) => GRead1Con (f :.: g) where + gliftReadPrecCon t rp rl = coerceComp1 $ readS_to_Prec $ liftReadsPrec (readPrec_to_S grpc) (readPrec_to_S (list grpc) 0) where - grpc = gliftReadPrecCon t (NonV4Read1Args rp rl) -#endif + grpc = gliftReadPrecCon t rp rl ------------------------------------------------------------------------------- -- * Show @@ -911,119 +693,88 @@ => Int -> f a -> ShowS showsPrecDefault = showsPrecOptions defaultOptions --- | Like 'showsPrecDefault', but with configurable 'Options'. +-- | Like 'showsPrecDefault', but with configurable 'Options'. Currently, the +-- 'Options' have no effect (but this may change in the future). showsPrecOptions :: (GShow (Rep1 f a), Generic1 f) => Options -> Int -> f a -> ShowS -showsPrecOptions opts p = gshowsPrec opts p . from1 +showsPrecOptions _ p = gshowsPrec p . from1 -- | Class of generic representation types that can be converted to a 'String'. class GShow a where - gshowsPrec :: Options -> Int -> a -> ShowS + gshowsPrec :: Int -> a -> ShowS instance GShow (f p) => GShow (D1 d f p) where - gshowsPrec opts p (M1 x) = gshowsPrec opts p x + gshowsPrec p (M1 x) = gshowsPrec p x instance GShow (V1 p) where - gshowsPrec _ = v1ShowsPrec + gshowsPrec = v1ShowsPrec instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where - gshowsPrec opts p (L1 x) = gshowsPrec opts p x - gshowsPrec opts p (R1 x) = gshowsPrec opts p x + gshowsPrec p (L1 x) = gshowsPrec p x + gshowsPrec p (R1 x) = gshowsPrec p x instance (Constructor c, GShowCon (f p), IsNullaryCon f) => GShow (C1 c f p) where - gshowsPrec opts = c1ShowsPrec $ gshowsPrecCon opts + gshowsPrec = c1ShowsPrec gshowsPrecCon -- | Class of generic representation types that can be converted to a 'String', and -- for which the 'ConType' has been determined. class GShowCon a where - gshowsPrecCon :: Options -> ConType -> Int -> a -> ShowS + gshowsPrecCon :: ConType -> Int -> a -> ShowS instance GShowCon (U1 p) where - gshowsPrecCon _ _ _ U1 = id + gshowsPrecCon _ _ U1 = id instance Show c => GShowCon (K1 i c p) where - gshowsPrecCon _ _ p (K1 x) = showsPrec p x + gshowsPrecCon _ p (K1 x) = showsPrec p x instance (Selector s, GShowCon (f p)) => GShowCon (S1 s f p) where - gshowsPrecCon opts = s1ShowsPrec . gshowsPrecCon opts + gshowsPrecCon = s1ShowsPrec . gshowsPrecCon instance (GShowCon (f p), GShowCon (g p)) => GShowCon ((f :*: g) p) where - gshowsPrecCon opts t = - productShowsPrec (gshowsPrecCon opts t) - (gshowsPrecCon opts t) - t + gshowsPrecCon t = productShowsPrec (gshowsPrecCon t) (gshowsPrecCon t) t instance Show p => GShowCon (Par1 p) where - gshowsPrecCon _ _ p (Par1 x) = showsPrec p x + gshowsPrecCon _ p (Par1 x) = showsPrec p x -#if defined(TRANSFORMERS_FOUR) instance (Show1 f, Show p) => GShowCon (Rec1 f p) where - gshowsPrecCon _ _ p (Rec1 x) = showsPrec1 p x - -instance (Functor f, Show1 f, GShowCon (g p)) => GShowCon ((f :.: g) p) where - gshowsPrecCon _ _ p (Comp1 x) = showsPrec1 p (fmap Apply x) -#else -instance (Show1 f, Show p) => GShowCon (Rec1 f p) where - gshowsPrecCon _ _ p (Rec1 x) = liftShowsPrec showsPrec showList p x + gshowsPrecCon _ p (Rec1 x) = liftShowsPrec showsPrec showList p x instance (Show1 f, GShowCon (g p)) => GShowCon ((f :.: g) p) where - gshowsPrecCon opts t p (Comp1 x) = - let glspc = gshowsPrecCon opts t + gshowsPrecCon t p (Comp1 x) = + let glspc = gshowsPrecCon t in liftShowsPrec glspc (showListWith (glspc 0)) p x -#endif -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) instance GShowCon (UChar p) where - gshowsPrecCon opts _ = uCharShowsPrec opts + gshowsPrecCon _ = uCharShowsPrec instance GShowCon (UDouble p) where - gshowsPrecCon opts _ = uDoubleShowsPrec opts + gshowsPrecCon _ = uDoubleShowsPrec instance GShowCon (UFloat p) where - gshowsPrecCon opts _ = uFloatShowsPrec opts + gshowsPrecCon _ = uFloatShowsPrec instance GShowCon (UInt p) where - gshowsPrecCon opts _ = uIntShowsPrec opts + gshowsPrecCon _ = uIntShowsPrec instance GShowCon (UWord p) where - gshowsPrecCon opts _ = uWordShowsPrec opts -#endif + gshowsPrecCon _ = uWordShowsPrec ------------------------------------------------------------------------------- -- * Show1 ------------------------------------------------------------------------------- --- | A 'Show1Args' value either stores a @Show a@ dictionary (for the --- @transformers-0.4@ version of 'Show1'), or it stores the two function arguments --- that show occurrences of the type parameter (for the non-@transformers-0.4@ --- version of 'Show1'). -data Show1Args v a where - V4Show1Args :: Show a => Show1Args V4 a - NonV4Show1Args :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Show1Args NonV4 a - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'showsPrec1' implementation for 'Generic1' instances. -showsPrec1Default :: (GShow1 V4 (Rep1 f), Generic1 f, Show a) - => Int -> f a -> ShowS -showsPrec1Default = showsPrec1Options defaultOptions - --- | Like 'showsPrec1Default', but with configurable 'Options'. -showsPrec1Options :: (GShow1 V4 (Rep1 f), Generic1 f, Show a) - => Options -> Int -> f a -> ShowS -showsPrec1Options opts p = gliftShowsPrec opts V4Show1Args p . from1 -#else -- | A sensible default 'liftShowsPrec' implementation for 'Generic1' instances. -liftShowsPrecDefault :: (GShow1 NonV4 (Rep1 f), Generic1 f) +liftShowsPrecDefault :: (GShow1 (Rep1 f), Generic1 f) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS liftShowsPrecDefault = liftShowsPrecOptions defaultOptions --- | Like 'liftShowsPrecDefault', but with configurable 'Options'. -liftShowsPrecOptions :: (GShow1 NonV4 (Rep1 f), Generic1 f) +-- | Like 'liftShowsPrecDefault', but with configurable 'Options'. Currently, +-- the 'Options' have no effect (but this may change in the future). +liftShowsPrecOptions :: (GShow1 (Rep1 f), Generic1 f) => Options -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS -liftShowsPrecOptions opts sp sl p = gliftShowsPrec opts (NonV4Show1Args sp sl) p . from1 -#endif +liftShowsPrecOptions _ sp sl p = gliftShowsPrec sp sl p . from1 -- | Class of generic representation types for unary type constructors that can -- be converted to a 'String'. @@ -1031,28 +782,25 @@ #if __GLASGOW_HASKELL__ >= 806 (forall a. Show a => GShow (f a)) => #endif - GShow1 v f where - gliftShowsPrec :: Options -> Show1Args v a -> Int -> f a -> ShowS + GShow1 f where + gliftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) + -> Int -> f a -> ShowS -instance GShow1 v f => GShow1 v (D1 d f) where - gliftShowsPrec opts sas p (M1 x) = gliftShowsPrec opts sas p x +instance GShow1 f => GShow1 (D1 d f) where + gliftShowsPrec sp sl p (M1 x) = gliftShowsPrec sp sl p x -instance GShow1 v V1 where +instance GShow1 V1 where gliftShowsPrec _ _ = v1ShowsPrec v1ShowsPrec :: Int -> V1 p -> ShowS -#if __GLASGOW_HASKELL__ >= 708 -v1ShowsPrec _ _ x = case x of {} -#else -v1ShowsPrec _ _ !_ = undefined -#endif +v1ShowsPrec _ x = case x of {} -instance (GShow1 v f, GShow1 v g) => GShow1 v (f :+: g) where - gliftShowsPrec opts sas p (L1 x) = gliftShowsPrec opts sas p x - gliftShowsPrec opts sas p (R1 x) = gliftShowsPrec opts sas p x +instance (GShow1 f, GShow1 g) => GShow1 (f :+: g) where + gliftShowsPrec sp sl p (L1 x) = gliftShowsPrec sp sl p x + gliftShowsPrec sp sl p (R1 x) = gliftShowsPrec sp sl p x -instance (Constructor c, GShow1Con v f, IsNullaryCon f) => GShow1 v (C1 c f) where - gliftShowsPrec opts sas = c1ShowsPrec $ \t -> gliftShowsPrecCon opts t sas +instance (Constructor c, GShow1Con f, IsNullaryCon f) => GShow1 (C1 c f) where + gliftShowsPrec sp sl = c1ShowsPrec $ \t -> gliftShowsPrecCon t sp sl c1ShowsPrec :: (Constructor c, IsNullaryCon f) => (ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS @@ -1094,18 +842,18 @@ #if __GLASGOW_HASKELL__ >= 806 (forall a. Show a => GShowCon (f a)) => #endif - GShow1Con v f where - gliftShowsPrecCon :: Options -> ConType -> Show1Args v a + GShow1Con f where + gliftShowsPrecCon :: ConType -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS -instance GShow1Con v U1 where +instance GShow1Con U1 where gliftShowsPrecCon _ _ _ _ U1 = id -instance Show c => GShow1Con v (K1 i c) where +instance Show c => GShow1Con (K1 i c) where gliftShowsPrecCon _ _ _ p (K1 x) = showsPrec p x -instance (Selector s, GShow1Con v f) => GShow1Con v (S1 s f) where - gliftShowsPrecCon opts t sas = s1ShowsPrec $ gliftShowsPrecCon opts t sas +instance (Selector s, GShow1Con f) => GShow1Con (S1 s f) where + gliftShowsPrecCon t sp sl = s1ShowsPrec $ gliftShowsPrecCon t sp sl s1ShowsPrec :: Selector s => (Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS s1ShowsPrec sp p sel@(M1 x) @@ -1123,10 +871,10 @@ selectorName :: String selectorName = selName sel -instance (GShow1Con v f, GShow1Con v g) => GShow1Con v (f :*: g) where - gliftShowsPrecCon opts t sas = - productShowsPrec (gliftShowsPrecCon opts t sas) - (gliftShowsPrecCon opts t sas) +instance (GShow1Con f, GShow1Con g) => GShow1Con (f :*: g) where + gliftShowsPrecCon t sp sl = + productShowsPrec (gliftShowsPrecCon t sp sl) + (gliftShowsPrecCon t sp sl) t productShowsPrec :: (Int -> f p -> ShowS) -> (Int -> g p -> ShowS) @@ -1156,70 +904,50 @@ then showString o else showChar '`' . showString o . showChar '`' -#if defined(TRANSFORMERS_FOUR) -instance GShow1Con V4 Par1 where - gliftShowsPrecCon _ _ V4Show1Args p (Par1 x) = showsPrec p x - -instance Show1 f => GShow1Con V4 (Rec1 f) where - gliftShowsPrecCon _ _ V4Show1Args p (Rec1 x) = showsPrec1 p x - -instance (Functor f, Show1 f, GShow1Con V4 g) => GShow1Con V4 (f :.: g) where - gliftShowsPrecCon _ _ V4Show1Args p (Comp1 x) = showsPrec1 p (fmap Apply1 x) -#else -instance GShow1Con NonV4 Par1 where - gliftShowsPrecCon _ _ (NonV4Show1Args sp _) p (Par1 x) = sp p x +instance GShow1Con Par1 where + gliftShowsPrecCon _ sp _ p (Par1 x) = sp p x -instance Show1 f => GShow1Con NonV4 (Rec1 f) where - gliftShowsPrecCon _ _ (NonV4Show1Args sp sl) p (Rec1 x) = liftShowsPrec sp sl p x +instance Show1 f => GShow1Con (Rec1 f) where + gliftShowsPrecCon _ sp sl p (Rec1 x) = liftShowsPrec sp sl p x -instance (Show1 f, GShow1Con NonV4 g) => GShow1Con NonV4 (f :.: g) where - gliftShowsPrecCon opts t (NonV4Show1Args sp sl) p (Comp1 x) = - let glspc = gliftShowsPrecCon opts t (NonV4Show1Args sp sl) +instance (Show1 f, GShow1Con g) => GShow1Con (f :.: g) where + gliftShowsPrecCon t sp sl p (Comp1 x) = + let glspc = gliftShowsPrecCon t sp sl in liftShowsPrec glspc (showListWith (glspc 0)) p x -#endif -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -instance GShow1Con v UChar where - gliftShowsPrecCon opts _ _ = uCharShowsPrec opts +instance GShow1Con UChar where + gliftShowsPrecCon _ _ _ = uCharShowsPrec -instance GShow1Con v UDouble where - gliftShowsPrecCon opts _ _ = uDoubleShowsPrec opts +instance GShow1Con UDouble where + gliftShowsPrecCon _ _ _ = uDoubleShowsPrec -instance GShow1Con v UFloat where - gliftShowsPrecCon opts _ _ = uFloatShowsPrec opts +instance GShow1Con UFloat where + gliftShowsPrecCon _ _ _ = uFloatShowsPrec -instance GShow1Con v UInt where - gliftShowsPrecCon opts _ _ = uIntShowsPrec opts +instance GShow1Con UInt where + gliftShowsPrecCon _ _ _ = uIntShowsPrec -instance GShow1Con v UWord where - gliftShowsPrecCon opts _ _ = uWordShowsPrec opts +instance GShow1Con UWord where + gliftShowsPrecCon _ _ _ = uWordShowsPrec -uCharShowsPrec :: Options -> Int -> UChar p -> ShowS -uCharShowsPrec opts p (UChar c) = - showsPrec (hashPrec opts p) (C# c) . oneHash opts +uCharShowsPrec :: Int -> UChar p -> ShowS +uCharShowsPrec p (UChar c) = shows (C# c) . oneHash -uDoubleShowsPrec :: Options -> Int -> UDouble p -> ShowS -uDoubleShowsPrec opts p (UDouble d) = - showsPrec (hashPrec opts p) (D# d) . twoHash opts +uDoubleShowsPrec :: Int -> UDouble p -> ShowS +uDoubleShowsPrec p (UDouble d) = shows (D# d) . twoHash -uFloatShowsPrec :: Options -> Int -> UFloat p -> ShowS -uFloatShowsPrec opts p (UFloat f) = - showsPrec (hashPrec opts p) (F# f) . oneHash opts +uFloatShowsPrec :: Int -> UFloat p -> ShowS +uFloatShowsPrec p (UFloat f) = shows (F# f) . oneHash -uIntShowsPrec :: Options -> Int -> UInt p -> ShowS -uIntShowsPrec opts p (UInt i) = - showsPrec (hashPrec opts p) (I# i) . oneHash opts +uIntShowsPrec :: Int -> UInt p -> ShowS +uIntShowsPrec p (UInt i) = shows (I# i) . oneHash -uWordShowsPrec :: Options -> Int -> UWord p -> ShowS -uWordShowsPrec opts p (UWord w) = - showsPrec (hashPrec opts p) (W# w) . twoHash opts +uWordShowsPrec :: Int -> UWord p -> ShowS +uWordShowsPrec p (UWord w) = shows (W# w) . twoHash -oneHash, twoHash :: Options -> ShowS -hashPrec :: Options -> Int -> Int -oneHash opts = if ghc8ShowBehavior opts then showChar '#' else id -twoHash opts = if ghc8ShowBehavior opts then showString "##" else id -hashPrec opts = if ghc8ShowBehavior opts then const 0 else id -#endif +oneHash, twoHash :: ShowS +oneHash = showChar '#' +twoHash = showString "##" ------------------------------------------------------------------------------- -- * GenericFunctorClasses @@ -1230,25 +958,14 @@ newtype FunctorClassesDefault f a = FunctorClassesDefault { getFunctorClassesDefault :: f a } -#if defined(TRANSFORMERS_FOUR) -instance (GEq1 V4 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where - eq1 (FunctorClassesDefault x) (FunctorClassesDefault y) = eq1Default x y -instance (GOrd1 V4 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where - compare1 (FunctorClassesDefault x) (FunctorClassesDefault y) = compare1Default x y -instance (GRead1 V4 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where - readsPrec1 p = coerceFCD (readsPrec1Default p) -instance (GShow1 V4 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where - showsPrec1 p (FunctorClassesDefault x) = showsPrec1Default p x -#else -instance (GEq1 NonV4 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where +instance (GEq1 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where liftEq f (FunctorClassesDefault x) (FunctorClassesDefault y) = liftEqDefault f x y -instance (GOrd1 NonV4 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where +instance (GOrd1 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where liftCompare f (FunctorClassesDefault x) (FunctorClassesDefault y) = liftCompareDefault f x y -instance (GRead1 NonV4 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where +instance (GRead1 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where liftReadsPrec rp rl p = coerceFCD (liftReadsPrecDefault rp rl p) -instance (GShow1 NonV4 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where +instance (GShow1 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where liftShowsPrec sp sl p (FunctorClassesDefault x) = liftShowsPrecDefault sp sl p x -#endif instance (GEq (Rep1 f a), Generic1 f) => Eq (FunctorClassesDefault f a) where FunctorClassesDefault x == FunctorClassesDefault y = eqDefault x y @@ -1266,36 +983,6 @@ -- * Shared code ------------------------------------------------------------------------------- -#if defined(TRANSFORMERS_FOUR) -newtype Apply g a = Apply { getApply :: g a } -newtype Apply1 g a = Apply1 { getApply1 :: g a } - -instance GEq (g a) => Eq (Apply g a) where - Apply x == Apply y = geq x y -instance (GEq1 V4 g, Eq a) => Eq (Apply1 g a) where - Apply1 x == Apply1 y = gliftEq V4Eq1Args x y - -instance GOrd (g a) => Ord (Apply g a) where - compare (Apply x) (Apply y) = gcompare x y -instance (GOrd1 V4 g, Ord a) => Ord (Apply1 g a) where - compare (Apply1 x) (Apply1 y) = gliftCompare V4Ord1Args x y - --- Passing defaultOptions and Pref below is OK, since it's guaranteed that the --- Options and ConType won't actually have any effect on how (g a) is shown. --- If we augment Options or ConType with more features in the future, this --- decision will need to be revisited. - -instance GReadCon (g a) => Read (Apply g a) where - readPrec = fmap Apply $ greadPrecCon Pref -instance (GRead1Con V4 g, Read a) => Read (Apply1 g a) where - readPrec = fmap Apply1 $ gliftReadPrecCon Pref V4Read1Args - -instance GShowCon (g a) => Show (Apply g a) where - showsPrec d = gshowsPrecCon defaultOptions Pref d . getApply -instance (GShow1Con V4 g, Show a) => Show (Apply1 g a) where - showsPrec d = gliftShowsPrecCon defaultOptions Pref V4Show1Args d . getApply1 -#endif - -- | Whether a constructor is a record ('Rec'), a tuple ('Tup'), is prefix ('Pref'), -- or infix ('Inf'). data ConType = Rec | Tup | Pref | Inf String @@ -1353,7 +1040,6 @@ instance IsNullaryCon (f :.: g) where isNullaryCon _ = False -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) instance IsNullaryCon UChar where isNullaryCon _ = False @@ -1368,9 +1054,3 @@ instance IsNullaryCon UWord where isNullaryCon _ = False - -# if __GLASGOW_HASKELL__ < 708 -isTrue# :: Bool -> Bool -isTrue# = id -# endif -#endif diff --git a/src/Control/Monad/Trans/Instances.hs b/src/Control/Monad/Trans/Instances.hs --- a/src/Control/Monad/Trans/Instances.hs +++ b/src/Control/Monad/Trans/Instances.hs @@ -1,1380 +1,201 @@ {-# LANGUAGE CPP #-} #ifndef HASKELL98 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif - -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif - -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE DataKinds #-} -# endif - -# if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE DeriveGeneric #-} -# 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 --- 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 qualified Control.Monad.Fail as Fail (MonadFail(..)) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Accum (AccumT(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Cont (ContT(..)) -import Control.Monad.Trans.Except (ExceptT(..)) -import Control.Monad.Trans.Identity (IdentityT(..)) -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 Control.Monad.Trans.Select (SelectT(..)) -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 (Sum(..)) - -import Control.Applicative -import Control.Arrow (Arrow((***))) -import Control.Monad (MonadPlus(..), liftM) -import Control.Monad.Fix (MonadFix(..)) -import Data.Bits -import Data.Foldable (Foldable(..)) -import Data.Ix (Ix(..)) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(..)) -import Data.String (IsString(fromString)) -import Data.Traversable (Traversable(..)) -import Foreign (Storable(..), castPtr) - -#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,9,0)) -import Data.Complex (Complex (..)) -#endif - -#if !(MIN_VERSION_transformers(0,6,0)) -import Control.Monad.Trans.Error (Error(..), ErrorT(..)) -import Control.Monad.Trans.List (ListT(..), mapListT) -#endif - -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(..)) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy(..)) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Bifunctor (Bifunctor(..)) -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Semigroup as Semigroup (Semigroup(..)) -#endif - -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable (Bifoldable(..)) -import Data.Bitraversable (Bitraversable(..)) -#endif - -#ifndef HASKELL98 -import Data.Data (Data) -import Data.Typeable - -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -# endif -#endif - -#if !(MIN_VERSION_transformers(0,3,0)) --- Foldable/Traversable instances -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 (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) - -# if !(MIN_VERSION_transformers(0,6,0)) -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 (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 -# endif - --- 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)) \ - || (MIN_VERSION_transformers(0,5,0) && !(MIN_VERSION_base(4,9,0))) --- MonadFail instances -instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where - fail msg = ContT $ \ _ -> Fail.fail msg - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where - fail msg = IdentityT $ Fail.fail msg - {-# INLINE fail #-} - -instance (Monad m) => Fail.MonadFail (MaybeT m) where - fail _ = MaybeT (return Nothing) - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where - fail msg = lift (Fail.fail msg) - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.RWST r w s m) where - fail msg = Lazy.RWST $ \ _ _ -> Fail.fail msg - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.RWST r w s m) where - fail msg = Strict.RWST $ \ _ _ -> Fail.fail msg - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (Lazy.StateT s m) where - fail str = Lazy.StateT $ \ _ -> Fail.fail str - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (Strict.StateT s m) where - fail str = Strict.StateT $ \ _ -> Fail.fail str - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.WriterT w m) where - fail msg = Lazy.WriterT $ Fail.fail msg - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.WriterT w m) where - fail msg = Strict.WriterT $ Fail.fail msg - {-# INLINE fail #-} - -# if !(MIN_VERSION_transformers(0,6,0)) -instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where - fail msg = ErrorT $ return (Left (strMsg msg)) - -instance (Monad m) => Fail.MonadFail (ListT m) where - fail _ = ListT $ return [] - {-# INLINE fail #-} -# endif - -# if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_base(4,9,0)) -instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where - fail = ExceptT . Fail.fail - {-# INLINE fail #-} -# endif - -# if MIN_VERSION_transformers(0,5,3) && !(MIN_VERSION_base(4,9,0)) -instance (Monoid w, Functor m, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where - fail msg = AccumT $ const (Fail.fail msg) - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where - fail msg = lift (Fail.fail msg) - {-# INLINE fail #-} -# endif -#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 (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_transformers(0,6,0)) -instance (MonadZip m) => MonadZip (ListT m) where - mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b -# endif - -# 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 ContT -deriving instance Typeable IdentityT -deriving instance Typeable Lift -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_transformers(0,6,0)) -deriving instance Typeable ErrorT -deriving instance Typeable ListT -# endif - -# 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__ >= 708 -deriving instance Typeable 'Identity -# endif -# endif - -# if !(MIN_VERSION_base(4,9,0)) -# 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 :: *)) - -# if MIN_VERSION_transformers(0,4,0) --- Typeable/Data instances for Sum --- These are also present in Data.Functor.Sum in transformers-compat, but only --- these are reachable if using @transformers-0.4.0.0@ -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 -# endif -# endif -#endif - -#if !(MIN_VERSION_transformers(0,5,1)) -# if !(MIN_VERSION_base(4,8,0)) -instance (Bounded a) => Bounded (Identity a) where - minBound = Identity minBound - maxBound = Identity maxBound - -instance (Enum a) => Enum (Identity a) where - succ (Identity x) = Identity (succ x) - pred (Identity x) = Identity (pred x) - toEnum i = Identity (toEnum i) - fromEnum (Identity x) = fromEnum x - enumFrom (Identity x) = map Identity (enumFrom x) - enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y) - enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y) - enumFromThenTo (Identity x) (Identity y) (Identity z) = - map Identity (enumFromThenTo x y z) - -instance (Ix a) => Ix (Identity a) where - range (Identity x, Identity y) = map Identity (range (x, y)) - index (Identity x, Identity y) (Identity i) = index (x, y) i - inRange (Identity x, Identity y) (Identity e) = inRange (x, y) e - rangeSize (Identity x, Identity y) = rangeSize (x, y) - -instance (Storable a) => Storable (Identity a) where - sizeOf (Identity x) = sizeOf x - alignment (Identity x) = alignment x - peekElemOff p i = fmap Identity (peekElemOff (castPtr p) i) - pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x - peekByteOff p i = fmap Identity (peekByteOff p i) - pokeByteOff p i (Identity x) = pokeByteOff p i x - peek p = fmap runIdentity (peek (castPtr p)) - poke p (Identity x) = poke (castPtr p) x -# endif -#endif - -#if !(MIN_VERSION_transformers(0,5,3)) -# if !(MIN_VERSION_base(4,9,0)) -# if MIN_VERSION_base(4,7,0) --- Data.Proxy -# if defined(TRANSFORMERS_FOUR) -instance Eq1 Proxy where - eq1 _ _ = True - -instance Ord1 Proxy where - compare1 _ _ = EQ - -instance Show1 Proxy where - showsPrec1 _ _ = showString "Proxy" - -instance Read1 Proxy where - readsPrec1 d = - readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) -# elif MIN_VERSION_transformers(0,5,0) -instance Eq1 Proxy where - liftEq _ _ _ = True - -instance Ord1 Proxy where - liftCompare _ _ _ = EQ - -instance Show1 Proxy where - liftShowsPrec _ _ _ _ = showString "Proxy" - -instance Read1 Proxy where - liftReadsPrec _ _ d = - readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) -# endif -# endif -# endif - -# if !(MIN_VERSION_base(4,8,0)) --- Data.Functor.Identity -instance (Bits a) => Bits (Identity a) where - Identity x .&. Identity y = Identity (x .&. y) - Identity x .|. Identity y = Identity (x .|. y) - xor (Identity x) (Identity y) = Identity (xor x y) - complement (Identity x) = Identity (complement x) - shift (Identity x) i = Identity (shift x i) - rotate (Identity x) i = Identity (rotate x i) - setBit (Identity x) i = Identity (setBit x i) - clearBit (Identity x) i = Identity (clearBit x i) - shiftL (Identity x) i = Identity (shiftL x i) - shiftR (Identity x) i = Identity (shiftR x i) - rotateL (Identity x) i = Identity (rotateL x i) - rotateR (Identity x) i = Identity (rotateR x i) - testBit (Identity x) i = testBit x i - bitSize (Identity x) = bitSize x - isSigned (Identity x) = isSigned x - bit i = Identity (bit i) -# if MIN_VERSION_base(4,5,0) - unsafeShiftL (Identity x) i = Identity (unsafeShiftL x i) - unsafeShiftR (Identity x) i = Identity (unsafeShiftR x i) - popCount (Identity x) = popCount x -# endif -# if MIN_VERSION_base(4,7,0) - zeroBits = Identity zeroBits - bitSizeMaybe (Identity x) = bitSizeMaybe x -# endif - -# if MIN_VERSION_base(4,7,0) -instance (FiniteBits a) => FiniteBits (Identity a) where - finiteBitSize (Identity x) = finiteBitSize x -# endif - -instance (Floating a) => Floating (Identity a) where - pi = Identity pi - exp (Identity x) = Identity (exp x) - log (Identity x) = Identity (log x) - sqrt (Identity x) = Identity (sqrt x) - sin (Identity x) = Identity (sin x) - cos (Identity x) = Identity (cos x) - tan (Identity x) = Identity (tan x) - asin (Identity x) = Identity (asin x) - acos (Identity x) = Identity (acos x) - atan (Identity x) = Identity (atan x) - sinh (Identity x) = Identity (sinh x) - cosh (Identity x) = Identity (cosh x) - tanh (Identity x) = Identity (tanh x) - asinh (Identity x) = Identity (asinh x) - acosh (Identity x) = Identity (acosh x) - atanh (Identity x) = Identity (atanh x) - Identity x ** Identity y = Identity (x ** y) - logBase (Identity x) (Identity y) = Identity (logBase x y) - -instance (Fractional a) => Fractional (Identity a) where - Identity x / Identity y = Identity (x / y) - recip (Identity x) = Identity (recip x) - fromRational r = Identity (fromRational r) - -instance (IsString a) => IsString (Identity a) where - fromString s = Identity (fromString s) - -instance (Integral a) => Integral (Identity a) where - quot (Identity x) (Identity y) = Identity (quot x y) - rem (Identity x) (Identity y) = Identity (rem x y) - div (Identity x) (Identity y) = Identity (div x y) - mod (Identity x) (Identity y) = Identity (mod x y) - quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y) - divMod (Identity x) (Identity y) = (Identity *** Identity) (divMod x y) - toInteger (Identity x) = toInteger x - -instance (Num a) => Num (Identity a) where - Identity x + Identity y = Identity (x + y) - Identity x - Identity y = Identity (x - y) - Identity x * Identity y = Identity (x * y) - negate (Identity x) = Identity (negate x) - abs (Identity x) = Identity (abs x) - signum (Identity x) = Identity (signum x) - fromInteger n = Identity (fromInteger n) - -instance (Real a) => Real (Identity a) where - toRational (Identity x) = toRational x - -instance (RealFloat a) => RealFloat (Identity a) where - floatRadix (Identity x) = floatRadix x - floatDigits (Identity x) = floatDigits x - floatRange (Identity x) = floatRange x - decodeFloat (Identity x) = decodeFloat x - exponent (Identity x) = exponent x - isNaN (Identity x) = isNaN x - isInfinite (Identity x) = isInfinite x - isDenormalized (Identity x) = isDenormalized x - isNegativeZero (Identity x) = isNegativeZero x - isIEEE (Identity x) = isIEEE x - significand (Identity x) = significand (Identity x) - scaleFloat s (Identity x) = Identity (scaleFloat s x) - encodeFloat m n = Identity (encodeFloat m n) - atan2 (Identity x) (Identity y) = Identity (atan2 x y) - -instance (RealFrac a) => RealFrac (Identity a) where - properFraction (Identity x) = (id *** Identity) (properFraction x) - truncate (Identity x) = truncate x - round (Identity x) = round x - ceiling (Identity x) = ceiling x - floor (Identity x) = floor x -# endif - -# if MIN_VERSION_transformers(0,3,0) --- Data.Functor.Reverse -instance (Monad m) => Monad (Reverse m) where - return a = Reverse (return a) - {-# INLINE return #-} - m >>= f = Reverse (getReverse m >>= getReverse . f) - {-# INLINE (>>=) #-} - fail msg = Reverse (fail msg) - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where - fail msg = Reverse (Fail.fail msg) - {-# INLINE fail #-} - -instance (MonadPlus m) => MonadPlus (Reverse m) where - mzero = Reverse mzero - {-# INLINE mzero #-} - Reverse x `mplus` Reverse y = Reverse (x `mplus` y) - {-# INLINE mplus #-} -# endif -#endif - -#if !(MIN_VERSION_transformers(0,5,4)) -# if MIN_VERSION_base(4,10,0) -instance Bifoldable Constant where - bifoldMap f _ (Constant a) = f a - {-# INLINE bifoldMap #-} - -instance Bitraversable Constant where - bitraverse f _ (Constant a) = Constant <$> f a - {-# INLINE bitraverse #-} -# endif -#endif - -#if !(MIN_VERSION_transformers(0,5,5)) -# if MIN_VERSION_base(4,9,0) -instance (Semigroup.Semigroup a) => Semigroup.Semigroup (Constant a b) where - Constant x <> Constant y = Constant (x Semigroup.<> y) - {-# INLINE (<>) #-} -# endif - -# if !(MIN_VERSION_transformers(0,6,0)) -instance (MonadFix m) => MonadFix (ListT m) where - mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of - [] -> return [] - x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f))) - {-# INLINE mfix #-} -# endif -#endif - --- Generic(1) instances -#ifndef HASKELL98 -# if (!(MIN_VERSION_transformers(0,5,0)) && (__GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING))) \ - || (MIN_VERSION_transformers(0,5,0) && __GLASGOW_HASKELL__ < 702 && defined(GENERIC_DERIVING)) - -# if !(MIN_VERSION_base(4,8,0)) -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 !(MIN_VERSION_base(4,9,0)) --- 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" - -# if MIN_VERSION_transformers(0,4,0) --- Generic(1) instances for Sum --- These are also present in Data.Functor.Sum in transformers-compat, but only --- these are reachable if using @transformers-0.4.0.0@ or later -instance Generic (Sum f g a) where - type Rep (Sum f g a) = - D1 MDSum (C1 MCInL (S1 NoSelector (Rec0 (f a))) - :+: C1 MCInR (S1 NoSelector (Rec0 (g a)))) - from (InL f) = M1 (L1 (M1 (M1 (K1 f)))) - from (InR g) = M1 (R1 (M1 (M1 (K1 g)))) - to (M1 (L1 (M1 (M1 (K1 f))))) = InL f - to (M1 (R1 (M1 (M1 (K1 g))))) = InR g - -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) - -data MDSum -data MCInL -data MCInR - -instance Datatype MDSum where - datatypeName _ = "Sum" - moduleName _ = "Data.Functor.Sum" - -instance Constructor MCInL where - conName _ = "InL" - -instance Constructor MCInR where - conName _ = "InR" -# endif -# endif - -# endif - -# if !(MIN_VERSION_transformers(0,6,0)) -# if __GLASGOW_HASKELL__ >= 708 --- If we wanted to be 100% faithful to the original Data instance in --- transformers, we really ought to define an instance like: --- --- instance (Data a, Typeable k, Typeable (b :: k)) => Data (Constant a b) --- --- Unfortunately, this is not possible to do with a standalone-derived Data --- instance (see https://gitlab.haskell.org/ghc/ghc/-/issues/13327). --- For now, I've opted to just restrict the instance context slightly by using --- a `Data b` constraint. I'll wait for someone to complain about this before --- taking further action on it. -deriving instance (Data a, Data b) => Data (Constant a b) -# if __GLASGOW_HASKELL__ < 710 -deriving instance Typeable Constant -# endif -# endif - --- The use of GHC 8.0 in this CPP is a conservative lower bound for --- determining the earliest version of GHC that can derive Generic(1) --- instances for all data types without bugs. We might be able to pick --- an earlier GHC version for certain data types, but it doesn't seem --- worthwhile, given that we'll have to fall back on hand-written instances at --- some point anyway. -# if __GLASGOW_HASKELL__ >= 800 - -deriving instance Generic (Constant a b) -deriving instance Generic1 (Constant a) - -deriving instance Generic (ContT r m a) - -deriving instance Generic (IdentityT f a) -deriving instance Generic1 (IdentityT f) - -deriving instance Generic (MaybeT m a) -deriving instance Functor m => Generic1 (MaybeT m) - -deriving instance Generic (Lazy.RWST r w s m a) -deriving instance Generic (Strict.RWST r w s m a) - -deriving instance Generic (ReaderT r m a) -deriving instance Generic1 (ReaderT r m) - -deriving instance Generic (Lazy.StateT s m a) -deriving instance Generic (Strict.StateT s m a) - -deriving instance Generic (Lazy.WriterT w m a) -deriving instance Generic (Strict.WriterT w m a) - -# if MIN_VERSION_transformers(0,3,0) -deriving instance Generic (Backwards f a) -deriving instance Generic1 (Backwards f) - -deriving instance Generic (Lift f a) -deriving instance Generic1 (Lift f) - -deriving instance Generic (Reverse f a) -deriving instance Generic1 (Reverse f) -# endif - -# if MIN_VERSION_transformers(0,4,0) -deriving instance Generic (ExceptT e m a) -deriving instance Functor m => Generic1 (ExceptT e m) -# endif - -# if MIN_VERSION_transformers(0,5,3) -deriving instance Generic (AccumT w m a) -deriving instance Generic (SelectT w m a) -# endif - -# elif __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) - -instance Generic (Constant a b) where - type Rep (Constant a b) = D1 D1'Constant (C1 C1_0'Constant (S1 S1_0_0'Constant (Rec0 a))) - from (Constant x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Constant x - -instance Generic1 (Constant a) where - type Rep1 (Constant a) = D1 D1'Constant (C1 C1_0'Constant (S1 S1_0_0'Constant (Rec0 a))) - from1 (Constant x) = M1 (M1 (M1 (K1 x))) - to1 (M1 (M1 (M1 x))) = Constant (unK1 x) - -instance Datatype D1'Constant where - datatypeName _ = "Constant" - moduleName _ = "Data.Functor.Constant" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'Constant where - conName _ = "Constant" - conIsRecord _ = True - -instance Selector S1_0_0'Constant where - selName _ = "getConstant" - -data D1'Constant -data C1_0'Constant -data S1_0_0'Constant - ------ - -instance Generic (ContT r m a) where - type Rep (ContT r m a) = D1 D1'ContT (C1 C1_0'ContT (S1 S1_0_0'ContT (Rec0 ((a -> m r) -> m r)))) - from (ContT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = ContT x - -instance Datatype D1'ContT where - datatypeName _ = "ContT" - moduleName _ = "Control.Monad.Trans.Cont" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'ContT where - conName _ = "ContT" - conIsRecord _ = True - -instance Selector S1_0_0'ContT where - selName _ = "runContT" - -data D1'ContT -data C1_0'ContT -data S1_0_0'ContT - ------ - -instance Generic (IdentityT f a) where - type Rep (IdentityT f a) = D1 D1'IdentityT (C1 C1_0'IdentityT (S1 S1_0_0'IdentityT (Rec0 (f a)))) - from (IdentityT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = IdentityT x - -instance Generic1 (IdentityT f) where - type Rep1 (IdentityT f) = D1 D1'IdentityT (C1 C1_0'IdentityT (S1 S1_0_0'IdentityT (Rec1 f))) - from1 (IdentityT x) = M1 (M1 (M1 (Rec1 x))) - to1 (M1 (M1 (M1 x))) = IdentityT (unRec1 x) - -instance Datatype D1'IdentityT where - datatypeName _ = "IdentityT" - moduleName _ = "Control.Monad.Trans.Identity" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'IdentityT where - conName _ = "IdentityT" - conIsRecord _ = True - -instance Selector S1_0_0'IdentityT where - selName _ = "runIdentityT" - -data D1'IdentityT -data C1_0'IdentityT -data S1_0_0'IdentityT - ------ - -instance Generic (MaybeT m a) where - type Rep (MaybeT m a) = D1 D1'MaybeT (C1 C1_0'MaybeT (S1 S1_0_0'MaybeT (Rec0 (m (Maybe a))))) - from (MaybeT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = MaybeT x - -instance Functor m => Generic1 (MaybeT m) where - type Rep1 (MaybeT m) = D1 D1'MaybeT (C1 C1_0'MaybeT (S1 S1_0_0'MaybeT (m :.: Rec1 Maybe))) - from1 (MaybeT x) = M1 (M1 (M1 ((.) Comp1 (fmap Rec1) x))) - to1 (M1 (M1 (M1 x))) = MaybeT ((.) (fmap unRec1) unComp1 x) - -instance Datatype D1'MaybeT where - datatypeName _ = "MaybeT" - moduleName _ = "Control.Monad.Trans.Maybe" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'MaybeT where - conName _ = "MaybeT" - conIsRecord _ = True - -instance Selector S1_0_0'MaybeT where - selName _ = "runMaybeT" - -data D1'MaybeT -data C1_0'MaybeT -data S1_0_0'MaybeT - ------ - -instance Generic (Lazy.RWST r w s m a) where - type Rep (Lazy.RWST r w s m a) = D1 D1'RWSTLazy (C1 C1_0'RWST (S1 S1_0_0'RWST (Rec0 (r -> s -> m (a, s, w))))) - from (Lazy.RWST x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Lazy.RWST x - -instance Generic (Strict.RWST r w s m a) where - type Rep (Strict.RWST r w s m a) = D1 D1'RWSTStrict (C1 C1_0'RWST (S1 S1_0_0'RWST (Rec0 (r -> s -> m (a, s, w))))) - from (Strict.RWST x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Strict.RWST x - -instance Datatype D1'RWSTLazy where - datatypeName _ = "RWST" - moduleName _ = "Control.Monad.Trans.RWS.Lazy" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Datatype D1'RWSTStrict where - datatypeName _ = "RWST" - moduleName _ = "Control.Monad.Trans.RWS.Strict" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'RWST where - conName _ = "RWST" - conIsRecord _ = True - -instance Selector S1_0_0'RWST where - selName _ = "runRWST" - -data D1'RWSTLazy -data D1'RWSTStrict -data C1_0'RWST -data S1_0_0'RWST - ------ - -instance Generic (ReaderT r m a) where - type Rep (ReaderT r m a) = D1 D1'ReaderT (C1 C1_0'ReaderT (S1 S1_0_0'ReaderT (Rec0 (r -> m a)))) - from (ReaderT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = ReaderT x - -instance Datatype D1'ReaderT where - datatypeName _ = "ReaderT" - moduleName _ = "Control.Monad.Trans.Reader" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'ReaderT where - conName _ = "ReaderT" - conIsRecord _ = True - -instance Selector S1_0_0'ReaderT where - selName _ = "runReaderT" - -data D1'ReaderT -data C1_0'ReaderT -data S1_0_0'ReaderT - ------ - -instance Generic (Lazy.StateT s m a) where - type Rep (Lazy.StateT s m a) = D1 D1'StateTLazy (C1 C1_0'StateT (S1 S1_0_0'StateT (Rec0 (s -> m (a, s))))) - from (Lazy.StateT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Lazy.StateT x - -instance Generic (Strict.StateT s m a) where - type Rep (Strict.StateT s m a) = D1 D1'StateTStrict (C1 C1_0'StateT (S1 S1_0_0'StateT (Rec0 (s -> m (a, s))))) - from (Strict.StateT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Strict.StateT x - -instance Datatype D1'StateTLazy where - datatypeName _ = "StateT" - moduleName _ = "Control.Monad.Trans.State.Lazy" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Datatype D1'StateTStrict where - datatypeName _ = "StateT" - moduleName _ = "Control.Monad.Trans.State.Strict" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'StateT where - conName _ = "StateT" - conIsRecord _ = True - -instance Selector S1_0_0'StateT where - selName _ = "runStateT" - -data D1'StateTLazy -data D1'StateTStrict -data C1_0'StateT -data S1_0_0'StateT - ------ - -instance Generic (Lazy.WriterT w m a) where - type Rep (Lazy.WriterT w m a) = D1 D1'WriterTLazy (C1 C1_0'WriterT (S1 S1_0_0'WriterT (Rec0 (m (a, w))))) - from (Lazy.WriterT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Lazy.WriterT x - -instance Generic (Strict.WriterT w m a) where - type Rep (Strict.WriterT w m a) = D1 D1'WriterTStrict (C1 C1_0'WriterT (S1 S1_0_0'WriterT (Rec0 (m (a, w))))) - from (Strict.WriterT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Strict.WriterT x - -instance Datatype D1'WriterTLazy where - datatypeName _ = "WriterT" - moduleName _ = "Control.Monad.Trans.Writer.Lazy" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Datatype D1'WriterTStrict where - datatypeName _ = "WriterT" - moduleName _ = "Control.Monad.Trans.Writer.Strict" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'WriterT where - conName _ = "WriterT" - conIsRecord _ = True - -instance Selector S1_0_0'WriterT where - selName _ = "runWriterT" - -data D1'WriterTLazy -data D1'WriterTStrict -data C1_0'WriterT -data S1_0_0'WriterT - -# if MIN_VERSION_transformers(0,3,0) -instance Generic (Backwards f a) where - type Rep (Backwards f a) = D1 D1'Backwards (C1 C1_0'Backwards (S1 S1_0_0'Backwards (Rec0 (f a)))) - from (Backwards x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Backwards x - -instance Generic1 (Backwards f) where - type Rep1 (Backwards f) = D1 D1'Backwards (C1 C1_0'Backwards (S1 S1_0_0'Backwards (Rec1 f))) - from1 (Backwards x) = M1 (M1 (M1 (Rec1 x))) - to1 (M1 (M1 (M1 x))) = Backwards (unRec1 x) - -instance Datatype D1'Backwards where - datatypeName _ = "Backwards" - moduleName _ = "Control.Applicative.Backwards" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'Backwards where - conName _ = "Backwards" - conIsRecord _ = True - -instance Selector S1_0_0'Backwards where - selName _ = "forwards" - -data D1'Backwards -data C1_0'Backwards -data S1_0_0'Backwards - ------ - -instance Generic (Reverse f a) where - type Rep (Reverse f a) = D1 D1'Reverse (C1 C1_0'Reverse (S1 S1_0_0'Reverse (Rec0 (f a)))) - from (Reverse x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Reverse x - -instance Generic1 (Reverse f) where - type Rep1 (Reverse f) = D1 D1'Reverse (C1 C1_0'Reverse (S1 S1_0_0'Reverse (Rec1 f))) - from1 (Reverse x) = M1 (M1 (M1 (Rec1 x))) - to1 (M1 (M1 (M1 x))) = Reverse (unRec1 x) - -instance Datatype D1'Reverse where - datatypeName _ = "Reverse" - moduleName _ = "Data.Functor.Reverse" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'Reverse where - conName _ = "Reverse" - conIsRecord _ = True - -instance Selector S1_0_0'Reverse where - selName _ = "getReverse" - -data D1'Reverse -data C1_0'Reverse -data S1_0_0'Reverse - ------ - -instance Generic (Lift f a) where - type Rep (Lift f a) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector (Rec0 a)) :+: C1 C1_1'Lift (S1 NoSelector (Rec0 (f a)))) - from (Pure x) = M1 (L1 (M1 (M1 (K1 x)))) - from (Other x) = M1 (R1 (M1 (M1 (K1 x)))) - to (M1 (L1 (M1 (M1 (K1 x))))) = Pure x - to (M1 (R1 (M1 (M1 (K1 x))))) = Other x - -instance Generic1 (Lift f) where - type Rep1 (Lift f) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector Par1) :+: C1 C1_1'Lift (S1 NoSelector (Rec1 f))) - from1 (Pure x) = M1 (L1 (M1 (M1 (Par1 x)))) - from1 (Other x) = M1 (R1 (M1 (M1 (Rec1 x)))) - to1 (M1 (L1 (M1 (M1 x)))) = Pure (unPar1 x) - to1 (M1 (R1 (M1 (M1 x)))) = Other (unRec1 x) - -instance Datatype D1'Lift where - datatypeName _ = "Lift" - moduleName _ = "Control.Applicative.Lift" - -instance Constructor C1_0'Lift where - conName _ = "Pure" - -instance Constructor C1_1'Lift where - conName _ = "Other" - -data D1'Lift -data C1_0'Lift -data C1_1'Lift -# endif - -# if MIN_VERSION_transformers(0,4,0) -instance Generic (ExceptT e m a) where - type Rep (ExceptT e m a) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (Rec0 (m (Either e a))))) - from (ExceptT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = ExceptT x - -instance Functor m => Generic1 (ExceptT e m) where - type Rep1 (ExceptT e m) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (m :.: Rec1 (Either e)))) - from1 (ExceptT x) = M1 (M1 (M1 ((.) Comp1 (fmap Rec1) x))) - to1 (M1 (M1 (M1 x))) = ExceptT ((.) (fmap unRec1) unComp1 x) - -instance Datatype D1'ExceptT where - datatypeName _ = "ExceptT" - moduleName _ = "Control.Monad.Trans.Except" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'ExceptT where - conName _ = "ExceptT" - -data D1'ExceptT -data C1_0'ExceptT -# endif - -# if MIN_VERSION_transformers(0,5,3) -instance Generic (AccumT w m a) where - type Rep (AccumT w m a) = D1 D1'AccumT (C1 C1_0'AccumT (S1 NoSelector (Rec0 (w -> m (a, w))))) - from (AccumT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = AccumT x - -instance Datatype D1'AccumT where - datatypeName _ = "AccumT" - moduleName _ = "Control.Monad.Trans.Accum" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'AccumT where - conName _ = "AccumT" - -data D1'AccumT -data C1_0'AccumT - ------ - -instance Generic (SelectT r m a) where - type Rep (SelectT r m a) = D1 D1'SelectT (C1 C1_0'SelectT (S1 NoSelector (Rec0 ((a -> m r) -> m a)))) - from (SelectT x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = SelectT x - -instance Datatype D1'SelectT where - datatypeName _ = "SelectT" - moduleName _ = "Control.Monad.Trans.Select" -# if MIN_VERSION_base(4,7,0) - isNewtype _ = True -# endif - -instance Constructor C1_0'SelectT where - conName _ = "SelectT" - -data D1'SelectT -data C1_0'SelectT -# endif - -# endif -# endif -#endif - -#if !(MIN_VERSION_base(4,9,0)) -# if defined(TRANSFORMERS_FOUR) - -# if MIN_VERSION_base(4,4,0) -instance Eq1 Complex where eq1 = (==) -instance Read1 Complex where readsPrec1 = readsPrec -instance Show1 Complex where showsPrec1 = showsPrec -# endif - -instance (Eq a, Eq b) => Eq1 ((,,) a b) where eq1 = (==) -instance (Ord a, Ord b) => Ord1 ((,,) a b) where compare1 = compare -instance (Read a, Read b) => Read1 ((,,) a b) where readsPrec1 = readsPrec -instance (Show a, Show b) => Show1 ((,,) a b) where showsPrec1 = showsPrec - -instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where eq1 = (==) -instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where compare1 = compare -instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where readsPrec1 = readsPrec -instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where showsPrec1 = showsPrec -# elif MIN_VERSION_transformers(0,5,0) - -# if MIN_VERSION_base(4,4,0) -instance Eq1 Complex where - liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v - -instance Read1 Complex where - liftReadsPrec rdP _ p s = readParen (p > complexPrec) (\s' -> do - (x, s'') <- rdP (complexPrec+1) s' - (":+", s''') <- lex s'' - (y, s'''') <- rdP (complexPrec+1) s''' - return (x :+ y, s'''')) s - where - complexPrec = 6 - -instance Show1 Complex where - liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $ - sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y - where - complexPrec = 6 -# endif - -instance Eq a => Eq2 ((,,) a) where - liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) = - u1 == v1 && - e1 x1 x2 && e2 y1 y2 - -instance Ord a => Ord2 ((,,) a) where - liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) = - compare u1 v1 `mappend` - comp1 x1 x2 `mappend` comp2 y1 y2 - -instance Read a => Read2 ((,,) a) where - liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> - [((e1,e2,e3), y) | ("(",s) <- lex r, - (e1,t) <- readsPrec 0 s, - (",",u) <- lex t, - (e2,v) <- rp1 0 u, - (",",w) <- lex v, - (e3,x) <- rp2 0 w, - (")",y) <- lex x] - -instance Show a => Show2 ((,,) a) where - liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2) - = showChar '(' . showsPrec 0 x1 - . showChar ',' . sp1 0 y1 - . showChar ',' . sp2 0 y2 - . showChar ')' - -instance (Eq a, Eq b) => Eq1 ((,,) a b) where - liftEq = liftEq2 (==) - -instance (Ord a, Ord b) => Ord1 ((,,) a b) where - liftCompare = liftCompare2 compare - -instance (Read a, Read b) => Read1 ((,,) a b) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a, Show b) => Show1 ((,,) a b) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance (Eq a, Eq b) => Eq2 ((,,,) a b) where - liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) = - u1 == v1 && - u2 == v2 && - e1 x1 x2 && e2 y1 y2 - -instance (Ord a, Ord b) => Ord2 ((,,,) a b) where - liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) = - compare u1 v1 `mappend` - compare u2 v2 `mappend` - comp1 x1 x2 `mappend` comp2 y1 y2 - -instance (Read a, Read b) => Read2 ((,,,) a b) where - liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> - [((e1,e2,e3,e4), s9) | ("(",s1) <- lex r, - (e1,s2) <- readsPrec 0 s1, - (",",s3) <- lex s2, - (e2,s4) <- readsPrec 0 s3, - (",",s5) <- lex s4, - (e3,s6) <- rp1 0 s5, - (",",s7) <- lex s6, - (e4,s8) <- rp2 0 s7, - (")",s9) <- lex s8] - -instance (Show a, Show b) => Show2 ((,,,) a b) where - liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2) - = showChar '(' . showsPrec 0 x1 - . showChar ',' . showsPrec 0 x2 - . showChar ',' . sp1 0 y1 - . showChar ',' . sp2 0 y2 - . showChar ')' - -instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where - liftEq = liftEq2 (==) - -instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where - liftCompare = liftCompare2 compare - -instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#endif + +{-# OPTIONS_GHC -Wno-deprecations #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Instances +-- Copyright : (C) 2012-16 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- 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 qualified Control.Monad.Fail as Fail (MonadFail(..)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Accum (AccumT(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Cont (ContT(..)) +import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Identity (IdentityT(..)) +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 Control.Monad.Trans.Select (SelectT(..)) +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 (Sum(..)) + +import Control.Applicative +import Control.Arrow (Arrow((***))) +import Control.Monad (MonadPlus(..), liftM) +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Zip (MonadZip(..)) +import Data.Bifunctor (Bifunctor(..)) +import Data.Bits +import Data.Foldable (Foldable(..)) +import Data.Ix (Ix(..)) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import Data.Proxy (Proxy(..)) +import qualified Data.Semigroup as Semigroup (Semigroup(..)) +import Data.String (IsString(fromString)) +import Data.Traversable (Traversable(..)) +import Foreign (Storable(..), castPtr) + +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error (Error(..), ErrorT(..)) +import Control.Monad.Trans.List (ListT(..), mapListT) +#endif + +#if MIN_VERSION_base(4,10,0) +import Data.Bifoldable (Bifoldable(..)) +import Data.Bitraversable (Bitraversable(..)) +#endif + +#ifndef HASKELL98 +import Data.Data (Data) +import Data.Typeable +import GHC.Generics +#endif + +#if !(MIN_VERSION_transformers(0,5,3)) +-- Data.Functor.Reverse +instance (Monad m) => Monad (Reverse m) where + return a = Reverse (return a) + {-# INLINE return #-} + m >>= f = Reverse (getReverse m >>= getReverse . f) + {-# INLINE (>>=) #-} + fail msg = Reverse (fail msg) + {-# INLINE fail #-} + +instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where + fail msg = Reverse (Fail.fail msg) + {-# INLINE fail #-} + +instance (MonadPlus m) => MonadPlus (Reverse m) where + mzero = Reverse mzero + {-# INLINE mzero #-} + Reverse x `mplus` Reverse y = Reverse (x `mplus` y) + {-# INLINE mplus #-} +#endif + +#if !(MIN_VERSION_transformers(0,5,4)) +# if MIN_VERSION_base(4,10,0) +instance Bifoldable Constant where + bifoldMap f _ (Constant a) = f a + {-# INLINE bifoldMap #-} + +instance Bitraversable Constant where + bitraverse f _ (Constant a) = Constant <$> f a + {-# INLINE bitraverse #-} +# endif +#endif + +#if !(MIN_VERSION_transformers(0,5,5)) +instance (Semigroup.Semigroup a) => Semigroup.Semigroup (Constant a b) where + Constant x <> Constant y = Constant (x Semigroup.<> y) + {-# INLINE (<>) #-} + +# if !(MIN_VERSION_transformers(0,6,0)) +instance (MonadFix m) => MonadFix (ListT m) where + mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of + [] -> return [] + x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f))) + {-# INLINE mfix #-} +# endif +#endif + +-- Generic(1) instances +#ifndef HASKELL98 +# if !(MIN_VERSION_transformers(0,6,0)) +-- If we wanted to be 100% faithful to the original Data instance in +-- transformers, we really ought to define an instance like: +-- +-- instance (Data a, Typeable k, Typeable (b :: k)) => Data (Constant a b) +-- +-- Unfortunately, this is not possible to do with a standalone-derived Data +-- instance (see https://gitlab.haskell.org/ghc/ghc/-/issues/13327). +-- For now, I've opted to just restrict the instance context slightly by using +-- a `Data b` constraint. I'll wait for someone to complain about this before +-- taking further action on it. +deriving instance (Data a, Data b) => Data (Constant a b) + +deriving instance Generic (Constant a b) +deriving instance Generic1 (Constant a) + +deriving instance Generic (ContT r m a) + +deriving instance Generic (IdentityT f a) +deriving instance Generic1 (IdentityT f) + +deriving instance Generic (MaybeT m a) +deriving instance Functor m => Generic1 (MaybeT m) + +deriving instance Generic (Lazy.RWST r w s m a) +deriving instance Generic (Strict.RWST r w s m a) + +deriving instance Generic (ReaderT r m a) +deriving instance Generic1 (ReaderT r m) + +deriving instance Generic (Lazy.StateT s m a) +deriving instance Generic (Strict.StateT s m a) + +deriving instance Generic (Lazy.WriterT w m a) +deriving instance Generic (Strict.WriterT w m a) + +deriving instance Generic (Backwards f a) +deriving instance Generic1 (Backwards f) + +deriving instance Generic (Lift f a) +deriving instance Generic1 (Lift f) + +deriving instance Generic (Reverse f a) +deriving instance Generic1 (Reverse f) + +deriving instance Generic (ExceptT e m a) +deriving instance Functor m => Generic1 (ExceptT e m) + +# if MIN_VERSION_transformers(0,5,3) +deriving instance Generic (AccumT w m a) +deriving instance Generic (SelectT w m a) +# endif # endif #endif diff --git a/tests/GenericsTypes.hs b/tests/GenericsTypes.hs --- a/tests/GenericsTypes.hs +++ b/tests/GenericsTypes.hs @@ -1,27 +1,18 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -#endif module GenericsTypes where -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif - import Data.Functor.Classes import Data.Functor.Classes.Generic -#if __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) -#endif import GHC.Exts import Test.QuickCheck (Arbitrary(..), oneof) @@ -115,10 +106,7 @@ instance Arbitrary (Empty a) where arbitrary = return $ error "Arbitrary Empty" -#if __GLASGOW_HASKELL__ == 700 --- Workaround for GHC Trac #5041 -$(deriveRead ''T#) -#elif __GLASGOW_HASKELL__ == 804 +#if __GLASGOW_HASKELL__ == 804 -- Workaround for GHC Trac #14918 $(deriveRead ''T#) #else @@ -139,44 +127,21 @@ $(deriveAll1 ''Empty) #endif -#if __GLASGOW_HASKELL__ >= 706 deriving instance Generic1 TestParam deriving instance Generic1 T# deriving instance Generic1 Infix deriving instance Generic1 GADT deriving instance Generic1 Record -#else -$(deriveAll1 ''TestParam) -$(deriveAll1 ''T#) -$(deriveAll1 ''Infix) -$(deriveAll1 ''GADT) -$(deriveAll1 ''Record) -#endif -#if __GLASGOW_HASKELL__ >= 800 deriving instance Generic1 Prim -#else -$(deriveAll1 ''Prim) -#endif #define CLASS1_INSTANCE(class,type,method,impl) \ instance class type where { method = impl }; \ -#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) -# define TRANSFORMERS_FOUR 1 -#endif - -#if defined(TRANSFORMERS_FOUR) -# define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,eq1,eq1Default) -# define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,compare1,compare1Default) -# define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,readsPrec1,readsPrec1Default) -# define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,showsPrec1,showsPrec1Default) -#else -# define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,liftEq,liftEqDefault) -# define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,liftCompare,liftCompareDefault) -# define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,liftReadsPrec,liftReadsPrecDefault) -# define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,liftShowsPrec,liftShowsPrecDefault) -#endif +#define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,liftEq,liftEqDefault) +#define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,liftCompare,liftCompareDefault) +#define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,liftReadsPrec,liftReadsPrecDefault) +#define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,liftShowsPrec,liftShowsPrecDefault) #define CLASS1_INSTANCES(type) \ EQ1_INSTANCE(type) \ diff --git a/tests/transformers-compat-tests.cabal b/tests/transformers-compat-tests.cabal --- a/tests/transformers-compat-tests.cabal +++ b/tests/transformers-compat-tests.cabal @@ -7,30 +7,30 @@ author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional -homepage: http://github.com/ekmett/transformers-compat/ -bug-reports: http://github.com/ekmett/transformers-compat/issues +homepage: https://github.com/ekmett/transformers-compat/ +bug-reports: https://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: transformers-compat tests description: @transformers-copmat@ tests build-type: Simple -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 - , GHC == 9.0.1 - , GHC == 9.2.1 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 source-repository head type: git - location: git://github.com/ekmett/transformers-compat.git + location: https://github.com/ekmett/transformers-compat.git flag tests default: True @@ -44,14 +44,14 @@ main-is: Spec.hs other-modules: GenericsSpec GenericsTypes - build-depends: base >= 4.3 && < 5 - , deriving-compat >= 0.4 && < 1 - , generic-deriving >= 1.10 && < 2 - , hspec >= 2 && < 3 - , QuickCheck >= 2 && < 3 - , tagged >= 0.7 && < 1 - , transformers >= 0.2 && < 0.7 + build-depends: base >= 4.3 && < 5 + , hspec >= 2 && < 3 + , QuickCheck >= 2 && < 3 , transformers-compat + if !impl(ghc >= 8.4) + build-depends: generic-deriving >= 1.10 && < 2 + if !impl(ghc >= 8.6) + build-depends: deriving-compat >= 0.4 && < 1 build-tool-depends: hspec-discover:hspec-discover >= 2 && < 3 hs-source-dirs: . ghc-options: -Wall -threaded -rtsopts diff --git a/transformers-compat.cabal b/transformers-compat.cabal --- a/transformers-compat.cabal +++ b/transformers-compat.cabal @@ -1,42 +1,41 @@ name: transformers-compat category: Compatibility -version: 0.7.2 +version: 0.8 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional -homepage: http://github.com/ekmett/transformers-compat/ -bug-reports: http://github.com/ekmett/transformers-compat/issues +homepage: https://github.com/ekmett/transformers-compat/ +bug-reports: https://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: A small compatibility shim for the transformers library description: - This package includes backported versions of types that were added - 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. + This package includes backported versions of types that were added to + @transformers@ in @transformers-0.5@ for users who need strict + @transformers-0.5@ compatibility, but also need those types. . - Those users should be able to just depend on @transformers >= 0.2@ - and @transformers-compat >= 0.3@. + Those users should be able to just depend on @transformers >= 0.5@ and + @transformers-compat >= 0.7.3@. . Note: missing methods are not supplied, but this at least permits the types to be used. build-type: Simple -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 - , GHC == 9.0.1 - , GHC == 9.2.1 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 extra-source-files: .ghci .gitignore @@ -51,22 +50,7 @@ source-repository head type: git - location: git://github.com/ekmett/transformers-compat.git - -flag two - default: False - description: Use transformers 0.2. This will be selected by cabal picking the appropriate version. - manual: False - -flag three - default: False - manual: False - description: Use transformers 0.3. This will be selected by cabal picking the appropriate version. - -flag four - default: False - manual: False - description: Use transformers 0.4. This will be selected by cabal picking the appropriate version. + location: https://github.com/ekmett/transformers-compat.git flag five default: False @@ -94,13 +78,11 @@ library build-depends: - base >= 4.3 && < 5, + base >= 4.9 && < 5, -- These are all transformers versions we support. -- each flag below splits this interval into two parts. -- flag-true parts are mutually exclusive, so at least one have to be on. - transformers >= 0.2 && <0.7 - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* + transformers >= 0.5 && <0.7 hs-source-dirs: src @@ -124,68 +106,22 @@ hs-source-dirs: 0.5 build-depends: transformers >= 0.5 && < 0.5.3 else - build-depends: transformers < 0.5 || >= 0.5.3 - - if flag(four) - cpp-options: -DTRANSFORMERS_FOUR - hs-source-dirs: 0.5 - -- Don't allow transformers-0.4.0.0 - -- See https://github.com/ekmett/transformers-compat/issues/35 - build-depends: transformers >= 0.4.1 && < 0.5 - else - build-depends: transformers < 0.4 || >= 0.5 - - if flag(three) - hs-source-dirs: 0.3 0.5 - build-depends: transformers >= 0.3 && < 0.4 - if flag(mtl) - build-depends: mtl >= 2.1 && < 2.2 - else - build-depends: transformers < 0.3 || >= 0.4 - - if flag(two) - hs-source-dirs: 0.2 0.3 0.5 - build-depends: transformers >= 0.2 && < 0.3 - if flag(mtl) - build-depends: mtl >= 2.0 && < 2.1 - else - build-depends: transformers >= 0.3 + build-depends: transformers >= 0.5.3 -- other flags - if impl(ghc >= 7.2) || flag(generic-deriving) + if impl(ghc) && flag(generic-deriving) hs-source-dirs: generics - build-depends: ghc-prim + exposed-modules: + Data.Functor.Classes.Generic + Data.Functor.Classes.Generic.Internal if flag(mtl) cpp-options: -DMTL - if flag(generic-deriving) - if impl(ghc < 8.0) && flag(generic-deriving) - cpp-options: -DGENERIC_DERIVING - build-depends: generic-deriving >= 1.10 && < 2 - if !flag(mtl) && !flag(generic-deriving) cpp-options: -DHASKELL98 - if flag(two) - exposed-modules: - Control.Applicative.Backwards - Control.Applicative.Lift - Data.Functor.Reverse - - if flag(two) || flag(three) - exposed-modules: - Control.Monad.Trans.Except - Control.Monad.Signatures - Data.Functor.Classes - Data.Functor.Sum - - if flag(two) || flag(three) || flag(four) || flag(five) + if flag(five) exposed-modules: Control.Monad.Trans.Accum Control.Monad.Trans.Select - - if impl(ghc >= 7.2) || flag(generic-deriving) - exposed-modules: - Data.Functor.Classes.Generic - Data.Functor.Classes.Generic.Internal