transformers-compat 0.7.2 → 0.8
raw patch · 16 files changed
+443/−4269 lines, 16 filesdep −faildep −generic-derivingdep −ghc-primdep ~basedep ~transformers
Dependencies removed: fail, generic-deriving, ghc-prim, mtl
Dependency ranges changed: base, transformers
Files
- 0.2/Control/Applicative/Backwards.hs +0/−153
- 0.2/Control/Applicative/Lift.hs +0/−210
- 0.2/Data/Functor/Reverse.hs +0/−168
- 0.3/Control/Monad/Signatures.hs +0/−61
- 0.3/Control/Monad/Trans/Except.hs +0/−418
- 0.3/Data/Functor/Classes.hs +0/−963
- 0.3/Data/Functor/Sum.hs +0/−143
- 0.5/Control/Monad/Trans/Accum.hs +3/−52
- 0.5/Control/Monad/Trans/Select.hs +4/−46
- CHANGELOG.markdown +15/−0
- generics/Data/Functor/Classes/Generic.hs +2/−38
- generics/Data/Functor/Classes/Generic/Internal.hs +171/−491
- src/Control/Monad/Trans/Instances.hs +196/−1375
- tests/GenericsTypes.hs +7/−42
- tests/transformers-compat-tests.cabal +19/−19
- transformers-compat.cabal +26/−90
− 0.2/Control/Applicative/Backwards.hs
@@ -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 #-}
− 0.2/Control/Applicative/Lift.hs
@@ -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
− 0.2/Data/Functor/Reverse.hs
@@ -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 #-}
− 0.3/Control/Monad/Signatures.hs
@@ -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
− 0.3/Control/Monad/Trans/Except.hs
@@ -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
− 0.3/Data/Functor/Classes.hs
@@ -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---}
− 0.3/Data/Functor/Sum.hs
@@ -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
0.5/Control/Monad/Trans/Accum.hs view
@@ -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
0.5/Control/Monad/Trans/Select.hs view
@@ -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
CHANGELOG.markdown view
@@ -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
generics/Data/Functor/Classes/Generic.hs view
@@ -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 @ -}
generics/Data/Functor/Classes/Generic/Internal.hs view
@@ -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
src/Control/Monad/Trans/Instances.hs view
@@ -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 <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ Backports orphan instances which are not provided by other modules in--- @transformers-compat@.------------------------------------------------------------------------------module Control.Monad.Trans.Instances () where--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(a,b,c) 1-#endif--#ifndef MIN_VERSION_transformers-#define MIN_VERSION_transformers(a,b,c) 1-#endif--import Control.Applicative.Backwards (Backwards(..))-import Control.Applicative.Lift (Lift(..))-import 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 <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Backports orphan instances which are not provided by other modules in+-- @transformers-compat@.+----------------------------------------------------------------------------+module Control.Monad.Trans.Instances () where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(a,b,c) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(a,b,c) 1+#endif++import Control.Applicative.Backwards (Backwards(..))+import Control.Applicative.Lift (Lift(..))+import 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
tests/GenericsTypes.hs view
@@ -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) \
tests/transformers-compat-tests.cabal view
@@ -7,30 +7,30 @@ author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> 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
transformers-compat.cabal view
@@ -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 <ekmett@gmail.com> 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