transformers-compat 0.4.0.4 → 0.8
raw patch · 25 files changed
Files
- .gitignore +23/−0
- .hlint.yaml +3/−0
- .travis.yml +0/−29
- 0.2/Control/Applicative/Backwards.hs +0/−71
- 0.2/Control/Applicative/Lift.hs +0/−96
- 0.2/Data/Functor/Reverse.hs +0/−76
- 0.3/Control/Monad/Signatures.hs +0/−32
- 0.3/Control/Monad/Trans/Except.hs +0/−283
- 0.3/Data/Functor/Classes.hs +0/−388
- 0.3/Data/Functor/Sum.hs +0/−59
- 0.5/Control/Monad/Trans/Accum.hs +292/−0
- 0.5/Control/Monad/Trans/Select.hs +158/−0
- CHANGELOG.markdown +214/−2
- HLint.hs +0/−1
- LICENSE +1/−1
- README.markdown +9/−1
- generics/Data/Functor/Classes/Generic.hs +79/−0
- generics/Data/Functor/Classes/Generic/Internal.hs +1056/−0
- src/Control/Monad/Trans/Instances.hs +201/−0
- tests/GenericsSpec.hs +99/−0
- tests/GenericsTypes.hs +161/−0
- tests/LICENSE +30/−0
- tests/Spec.hs +1/−0
- tests/transformers-compat-tests.cabal +58/−0
- transformers-compat.cabal +84/−49
.gitignore view
@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -7,3 +8,25 @@ .DS_Store .*.swp .*.swo+*.o+*.hi+*~+*#+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*
+ .hlint.yaml view
@@ -0,0 +1,3 @@+- arguments: [--cpp-define=HLINT, --cpp-ansi]++- ignore: {name: Avoid lambda}
− .travis.yml
@@ -1,29 +0,0 @@-language: haskell-before_install:- # Uncomment whenever hackage is down.- # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update-- # Try installing some of the build-deps with apt-get for speed.- - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode-- - sudo apt-get -q -y install hlint || cabal install hlint--install:- - cabal configure $mode- - cabal build--script:- - $script- - hlint 0.2 --cpp-define HLINT- - hlint 0.3 --cpp-define HLINT--notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313transformers-compat\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"--env:- - mode="--enable-tests" script="cabal test"
− 0.2/Control/Applicative/Backwards.hs
@@ -1,71 +0,0 @@--- |--- 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 Prelude hiding (foldr, foldr1, foldl, foldl1)-import Control.Applicative-import Data.Foldable-import Data.Functor.Classes-import Data.Traversable---- | The same functor, but with an 'Applicative' instance that performs--- actions in the reverse order.-newtype Backwards f a = Backwards { forwards :: f a }---- | Derived instance.-instance (Functor f) => Functor (Backwards f) where- fmap f (Backwards a) = Backwards (fmap f a)---- | Apply @f@-actions in the reverse order.-instance (Applicative f) => Applicative (Backwards f) where- pure a = Backwards (pure a)- Backwards f <*> Backwards a = Backwards (a <**> f)---- | Try alternatives in the same order as @f@.-instance (Alternative f) => Alternative (Backwards f) where- empty = Backwards empty- Backwards x <|> Backwards y = Backwards (x <|> y)---- | Derived instance.-instance (Foldable f) => Foldable (Backwards f) where- foldMap f (Backwards t) = foldMap f t- foldr f z (Backwards t) = foldr f z t- foldl f z (Backwards t) = foldl f z t- foldr1 f (Backwards t) = foldl1 f t- foldl1 f (Backwards t) = foldr1 f t---- | Derived instance.-instance (Traversable f) => Traversable (Backwards f) where- traverse f (Backwards t) = fmap Backwards (traverse f t)- sequenceA (Backwards t) = fmap Backwards (sequenceA t)---instance (Eq1 f, Eq a) => Eq (Backwards f a) where- Backwards x == Backwards y = eq1 x y--instance (Ord1 f, Ord a) => Ord (Backwards f a) where- compare (Backwards x) (Backwards y) = compare1 x y--instance (Read1 f, Read a) => Read (Backwards f a) where- readsPrec = readsData $ readsUnary1 "Backwards" Backwards--instance (Show1 f, Show a) => Show (Backwards f a) where- showsPrec d (Backwards x) = showsUnary1 "Backwards" d x--instance Eq1 f => Eq1 (Backwards f) where eq1 = (==)-instance Ord1 f => Ord1 (Backwards f) where compare1 = compare-instance Read1 f => Read1 (Backwards f) where readsPrec1 = readsPrec-instance Show1 f => Show1 (Backwards f) where showsPrec1 = showsPrec-
− 0.2/Control/Applicative/Lift.hs
@@ -1,96 +0,0 @@--- |--- 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 (- Lift(..), unLift,- -- * Collecting errors- Errors, failure- ) where--import Control.Applicative-import Data.Foldable (Foldable(foldMap))-import Data.Functor.Constant-import Data.Functor.Classes-import Data.Monoid-import Data.Traversable (Traversable(traverse))---- | Applicative functor formed by adding pure computations to a given--- applicative functor.-data Lift f a = Pure a | Other (f a)--instance (Eq1 f, Eq a) => Eq (Lift f a) where- Pure x1 == Pure x2 = x1 == x2- Other y1 == Other y2 = eq1 y1 y2- _ == _ = False--instance (Ord1 f, Ord a) => Ord (Lift f a) where- compare (Pure x1) (Pure x2) = compare x1 x2- compare (Pure _) (Other _) = LT- compare (Other _) (Pure _) = GT- compare (Other y1) (Other y2) = compare1 y1 y2--instance (Read1 f, Read a) => Read (Lift f a) where- readsPrec = readsData $- readsUnary "Pure" Pure `mappend` readsUnary1 "Other" Other--instance (Show1 f, Show a) => Show (Lift f a) where- showsPrec d (Pure x) = showsUnary "Pure" d x- showsPrec d (Other y) = showsUnary1 "Other" d y--instance (Eq1 f) => Eq1 (Lift f) where eq1 = (==)-instance (Ord1 f) => Ord1 (Lift f) where compare1 = compare-instance (Read1 f) => Read1 (Lift f) where readsPrec1 = readsPrec-instance (Show1 f) => Show1 (Lift f) where showsPrec1 = showsPrec--instance (Functor f) => Functor (Lift f) where- fmap f (Pure x) = Pure (f x)- fmap f (Other y) = Other (fmap f y)--instance (Foldable f) => Foldable (Lift f) where- foldMap f (Pure x) = f x- foldMap f (Other y) = foldMap f y--instance (Traversable f) => Traversable (Lift f) where- traverse f (Pure x) = Pure <$> f x- traverse f (Other y) = Other <$> traverse f y---- | A combination is 'Pure' only if both parts are.-instance (Applicative f) => Applicative (Lift f) where- pure = Pure- Pure f <*> Pure x = Pure (f x)- Pure f <*> Other y = Other (f <$> y)- Other f <*> Pure x = Other (($ x) <$> f)- Other f <*> Other y = Other (f <*> y)---- | A combination is 'Pure' only either part is.-instance Alternative f => Alternative (Lift f) where- empty = Other empty- Pure x <|> _ = Pure x- Other _ <|> Pure y = Pure y- Other x <|> Other y = Other (x <|> y)---- | Projection to the other functor.-unLift :: Applicative f => Lift f a -> f a-unLift (Pure x) = pure x-unLift (Other e) = e---- | An applicative functor that collects a monoid (e.g. lists) of errors.--- A sequence of computations fails if any of its components do, but--- unlike monads made with 'ErrorT' from "Control.Monad.Trans.Error",--- these computations continue after an error, collecting all the errors.-type Errors e = Lift (Constant e)---- | Report an error.-failure :: Monoid e => e -> Errors e a-failure e = Other (Constant e)
− 0.2/Data/Functor/Reverse.hs
@@ -1,76 +0,0 @@--- |--- 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 Prelude hiding (foldr, foldr1, foldl, foldl1)-import Control.Applicative-import Data.Foldable-import Data.Functor.Classes-import Data.Traversable-import Data.Monoid---- | 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 }---- | Derived instance.-instance (Functor f) => Functor (Reverse f) where- fmap f (Reverse a) = Reverse (fmap f a)---- | Derived instance.-instance (Applicative f) => Applicative (Reverse f) where- pure a = Reverse (pure a)- Reverse f <*> Reverse a = Reverse (f <*> a)---- | Derived instance.-instance (Alternative f) => Alternative (Reverse f) where- empty = Reverse empty- Reverse x <|> Reverse y = Reverse (x <|> y)---- | Fold from right to left.-instance (Foldable f) => Foldable (Reverse f) where- foldMap f (Reverse t) = getDual (foldMap (Dual . f) t)- foldr f z (Reverse t) = foldl (flip f) z t- foldl f z (Reverse t) = foldr (flip f) z t- foldr1 f (Reverse t) = foldl1 (flip f) t- foldl1 f (Reverse t) = foldr1 (flip f) t---- | Traverse from right to left.-instance (Traversable f) => Traversable (Reverse f) where- traverse f (Reverse t) =- fmap Reverse . forwards $ traverse (Backwards . f) t- sequenceA (Reverse t) =- fmap Reverse . forwards $ sequenceA (fmap Backwards t)--instance (Eq1 f, Eq a) => Eq (Reverse f a) where- Reverse x == Reverse y = eq1 x y--instance (Ord1 f, Ord a) => Ord (Reverse f a) where- compare (Reverse x) (Reverse y) = compare1 x y--instance (Read1 f, Read a) => Read (Reverse f a) where- readsPrec = readsData $ readsUnary1 "Reverse" Reverse--instance (Show1 f, Show a) => Show (Reverse f a) where- showsPrec d (Reverse x) = showsUnary1 "Reverse" d x--instance Eq1 f => Eq1 (Reverse f) where eq1 = (==)-instance Ord1 f => Ord1 (Reverse f) where compare1 = compare-instance Read1 f => Read1 (Reverse f) where readsPrec1 = readsPrec-instance Show1 f => Show1 (Reverse f) where showsPrec1 = showsPrec-
− 0.3/Control/Monad/Signatures.hs
@@ -1,32 +0,0 @@--------------------------------------------------------------------------------- |--- 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.--------------------------------------------------------------------------------module Control.Monad.Signatures (- CallCC, Catch, Listen, Pass- ) where---- | Signature of the @callCC@ operation,--- introduced in "Control.Monad.Trans.Cont".-type CallCC m a b = ((a -> m b) -> m a) -> m a---- | Signature of the @catchE@ operation,--- introduced in "Control.Monad.Trans.Except".-type Catch e m a = m a -> (e -> m a) -> m a---- | Signature of the @listen@ operation,--- introduced in "Control.Monad.Trans.Writer".-type Listen w m a = m a -> m (a, w)---- | Signature of the @pass@ operation,--- introduced in "Control.Monad.Trans.Writer".-type Pass w m a = m (a, w -> w) -> m a
− 0.3/Control/Monad/Trans/Except.hs
@@ -1,283 +0,0 @@-{-# LANGUAGE CPP #-}--#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif--#ifndef HASKELL98-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-#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,- -- * Lifting other operations- liftCallCC,- liftListen,- liftPass,- ) where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Signatures-import Control.Monad.Trans.Class--#ifndef HASKELL98-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))---- | 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 :: Either e a -> Except e a-except m = ExceptT (Identity m)---- | Extractor for computations in the exception monad.--- (The inverse of 'except').-runExcept :: Except e a -> Either e a-runExcept (ExceptT m) = runIdentity m---- | 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)---- | 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---- | 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) }--instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where- ExceptT x == ExceptT y = eq1 x y--instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where- compare (ExceptT x) (ExceptT y) = compare1 x y--instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where- readsPrec = readsData $ readsUnary1 "ExceptT" ExceptT--instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where- showsPrec d (ExceptT m) = showsUnary1 "ExceptT" d m--instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where eq1 = (==)-instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where compare1 = compare-instance (Read e, Read1 m) => Read1 (ExceptT e m) where readsPrec1 = readsPrec-instance (Show e, Show1 m) => Show1 (ExceptT e m) where showsPrec1 = showsPrec---- | 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)---- | 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--instance (Functor m) => Functor (ExceptT e m) where- fmap f = ExceptT . fmap (fmap f) . runExceptT--instance (Foldable f) => Foldable (ExceptT e f) where- foldMap f (ExceptT a) = foldMap (either (const mempty) f) a--instance (Traversable f) => Traversable (ExceptT e f) where- traverse f (ExceptT a) =- ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a--instance (Functor m, Monad m) => Applicative (ExceptT e m) where- pure a = ExceptT $ return (Right a)- 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))--instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where- empty = mzero- (<|>) = mplus--instance (Monad m) => Monad (ExceptT e m) where- return a = ExceptT $ return (Right a)- m >>= k = ExceptT $ do- a <- runExceptT m- case a of- Left e -> return (Left e)- Right x -> runExceptT (k x)- fail = ExceptT . fail--instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where- mzero = ExceptT $ return (Left mempty)- 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)--instance (MonadFix m) => MonadFix (ExceptT e m) where- mfix f = ExceptT $ mfix $ \ a -> runExceptT $ f $ case a of- Right x -> x- Left _ -> error "mfix ExceptT: Left"--instance MonadTrans (ExceptT e) where- lift = ExceptT . liftM Right--instance (MonadIO m) => MonadIO (ExceptT e m) where- liftIO = lift . liftIO---- | 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---- | 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)---- | 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)))---- | 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---- | 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)---- incurring the mtl dependency for these avoids packages that need them introducing orphans.--#ifndef HASKELL98--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,388 +0,0 @@-{-# LANGUAGE CPP #-}-#ifndef MIN_VERSION_transformers-#define MIN_VERSION_transformers(a,b,c) 1-#endif--- |--- Module : Data.Functor.Classes--- Copyright : (c) Ross Paterson 2013, Edward Kmett 2014--- License : BSD-style (see the file LICENSE)------ Maintainer : ross@soi.city.ac.uk--- Stability : experimental--- Portability : portable------ Prelude classes, lifted to unary type constructors.--module Data.Functor.Classes (- -- * Liftings of Prelude classes- Eq1(..),- Ord1(..),- Read1(..),- Show1(..),- -- * Helper functions- readsData,- readsUnary,- readsUnary1,- readsBinary1,- showsUnary,- showsUnary1,- showsBinary1,- ) where--import Control.Monad.Trans.Error-import Control.Monad.Trans.Identity-import Control.Monad.Trans.List-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Writer.Lazy as Lazy-import Control.Monad.Trans.Writer.Strict as Strict-import Data.Functor.Compose-import Data.Functor.Constant-import Data.Functor.Identity-import Data.Functor.Product-import Data.Monoid (Monoid(mappend))-#if MIN_VERSION_transformers(0,3,0)-import Control.Applicative.Lift-import Control.Applicative.Backwards-import Data.Functor.Reverse-#endif--instance Show a => Show (Identity a) where- showsPrec d (Identity a) = showParen (d > 10) $- showString "Identity " . showsPrec 11 a-instance Read a => Read (Identity a) where- readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s])-instance Eq a => Eq (Identity a) where- Identity a == Identity b = a == b-instance Ord a => Ord (Identity a) where- compare (Identity a) (Identity b) = compare a b--instance Show a => Show (Constant a b) where- showsPrec d (Constant a) = showParen (d > 10) $- showString "Constant " . showsPrec 11 a-instance Read a => Read (Constant a b) where- readsPrec d = readParen (d > 10) (\r -> [(Constant m,t) | ("Constant",s) <- lex r, (m,t) <- readsPrec 11 s])-instance Eq a => Eq (Constant a b) where- Constant a == Constant b = a == b-instance Ord a => Ord (Constant a b) where- compare (Constant a) (Constant b) = compare a b---- | Lifting of the 'Eq' class to unary type constructors.-class Eq1 f where- eq1 :: (Eq a) => f a -> f a -> Bool---- | Lifting of the 'Ord' class to unary type constructors.-class (Eq1 f) => Ord1 f where- compare1 :: (Ord a) => f a -> f a -> Ordering---- | Lifting of the 'Read' class to unary type constructors.-class Read1 f where- readsPrec1 :: (Read a) => Int -> ReadS (f a)---- | Lifting of the 'Show' class to unary type constructors.-class Show1 f where- showsPrec1 :: (Show a) => Int -> f a -> ShowS---- Instances for Prelude type constructors--instance Eq1 Maybe where eq1 = (==)-instance Ord1 Maybe where compare1 = compare-instance Read1 Maybe where readsPrec1 = readsPrec-instance Show1 Maybe where showsPrec1 = showsPrec--instance Eq1 [] where eq1 = (==)-instance Ord1 [] where compare1 = compare-instance Read1 [] where readsPrec1 = readsPrec-instance Show1 [] where showsPrec1 = showsPrec--instance (Eq a) => Eq1 ((,) a) where eq1 = (==)-instance (Ord a) => Ord1 ((,) a) where compare1 = compare-instance (Read a) => Read1 ((,) a) where readsPrec1 = readsPrec-instance (Show a) => Show1 ((,) a) where showsPrec1 = showsPrec--instance (Eq a) => Eq1 (Either a) where eq1 = (==)-instance (Ord a) => Ord1 (Either a) where compare1 = compare-instance (Read a) => Read1 (Either a) where readsPrec1 = readsPrec-instance (Show a) => Show1 (Either a) where showsPrec1 = showsPrec---- Building blocks---- | @'readsData' p d@ is a parser for datatypes where each alternative--- begins with a data constructor. It parses the constructor and--- passes it to @p@. Parsers for various constructors can be constructed--- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with--- @mappend@ from the @Monoid@ class.-readsData :: (String -> ReadS a) -> Int -> ReadS a-readsData reader d =- readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]---- | @'readsUnary' n c n'@ matches the name of a unary data constructor--- and then parses its argument using 'readsPrec'.-readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t-readsUnary name cons kw s =- [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]---- | @'readsUnary1' n c n'@ matches the name of a unary data constructor--- and then parses its argument using 'readsPrec1'.-readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t-readsUnary1 name cons kw s =- [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]---- | @'readsBinary1' n c n'@ matches the name of a binary data constructor--- and then parses its arguments using 'readsPrec1'.-readsBinary1 :: (Read1 f, Read1 g, Read a) =>- String -> (f a -> g a -> t) -> String -> ReadS t-readsBinary1 name cons kw s =- [(cons x y,u) | kw == name,- (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]---- | @'showsUnary' n d x@ produces the string representation of a unary data--- constructor with name @n@ and argument @x@, in precedence context @d@.-showsUnary :: (Show a) => String -> Int -> a -> ShowS-showsUnary name d x = showParen (d > 10) $- showString name . showChar ' ' . showsPrec 11 x---- | @'showsUnary1' n d x@ produces the string representation of a unary data--- constructor with name @n@ and argument @x@, in precedence context @d@.-showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS-showsUnary1 name d x = showParen (d > 10) $- showString name . showChar ' ' . showsPrec1 11 x---- | @'showsBinary1' n d x@ produces the string representation of a binary--- data constructor with name @n@ and arguments @x@ and @y@, in precedence--- context @d@.-showsBinary1 :: (Show1 f, Show1 g, Show a) =>- String -> Int -> f a -> g a -> ShowS-showsBinary1 name d x y = showParen (d > 10) $- showString name . showChar ' ' . showsPrec1 11 x .- showChar ' ' . showsPrec1 11 y---instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where- ErrorT x == ErrorT y = eq1 x y--instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where- compare (ErrorT x) (ErrorT y) = compare1 x y--instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where- readsPrec = readsData $ readsUnary1 "ErrorT" ErrorT--instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where- showsPrec d (ErrorT m) = showsUnary1 "ErrorT" d m--instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where eq1 = (==)-instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where compare1 = compare-instance (Read e, Read1 m) => Read1 (ErrorT e m) where readsPrec1 = readsPrec-instance (Show e, Show1 m) => Show1 (ErrorT e m) where showsPrec1 = showsPrec--instance (Eq1 f, Eq a) => Eq (IdentityT f a) where- IdentityT x == IdentityT y = eq1 x y--instance (Ord1 f, Ord a) => Ord (IdentityT f a) where- compare (IdentityT x) (IdentityT y) = compare1 x y--instance (Read1 f, Read a) => Read (IdentityT f a) where- readsPrec = readsData $ readsUnary1 "IdentityT" IdentityT--instance (Show1 f, Show a) => Show (IdentityT f a) where- showsPrec d (IdentityT m) = showsUnary1 "IdentityT" d m--instance Eq1 f => Eq1 (IdentityT f) where eq1 = (==)-instance Ord1 f => Ord1 (IdentityT f) where compare1 = compare-instance Read1 f => Read1 (IdentityT f) where readsPrec1 = readsPrec-instance Show1 f => Show1 (IdentityT f) where showsPrec1 = showsPrec--instance (Eq1 m, Eq a) => Eq (ListT m a) where- ListT x == ListT y = eq1 x y--instance (Ord1 m, Ord a) => Ord (ListT m a) where- compare (ListT x) (ListT y) = compare1 x y--instance (Read1 m, Read a) => Read (ListT m a) where- readsPrec = readsData $ readsUnary1 "ListT" ListT--instance (Show1 m, Show a) => Show (ListT m a) where- showsPrec d (ListT m) = showsUnary1 "ListT" d m--instance Eq1 m => Eq1 (ListT m) where eq1 = (==)-instance Ord1 m => Ord1 (ListT m) where compare1 = compare-instance Read1 m => Read1 (ListT m) where readsPrec1 = readsPrec-instance Show1 m => Show1 (ListT m) where showsPrec1 = showsPrec--instance (Eq1 m, Eq a) => Eq (MaybeT m a) where- MaybeT x == MaybeT y = eq1 x y--instance (Ord1 m, Ord a) => Ord (MaybeT m a) where- compare (MaybeT x) (MaybeT y) = compare1 x y--instance (Read1 m, Read a) => Read (MaybeT m a) where- readsPrec = readsData $ readsUnary1 "MaybeT" MaybeT--instance (Show1 m, Show a) => Show (MaybeT m a) where- showsPrec d (MaybeT m) = showsUnary1 "MaybeT" d m--instance Eq1 m => Eq1 (MaybeT m) where eq1 = (==)-instance Ord1 m => Ord1 (MaybeT m) where compare1 = compare-instance Read1 m => Read1 (MaybeT m) where readsPrec1 = readsPrec-instance Show1 m => Show1 (MaybeT m) where showsPrec1 = showsPrec--instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where- Lazy.WriterT x == Lazy.WriterT y = eq1 x y--instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where- compare (Lazy.WriterT x) (Lazy.WriterT y) = compare1 x y--instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where- readsPrec = readsData $ readsUnary1 "WriterT" Lazy.WriterT--instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where- showsPrec d (Lazy.WriterT m) = showsUnary1 "WriterT" d m--instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where eq1 = (==)-instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where compare1 = compare-instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where readsPrec1 = readsPrec-instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where showsPrec1 = showsPrec--instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where- Strict.WriterT x == Strict.WriterT y = eq1 x y--instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where- compare (Strict.WriterT x) (Strict.WriterT y) = compare1 x y--instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where- readsPrec = readsData $ readsUnary1 "WriterT" Strict.WriterT--instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where- showsPrec d (Strict.WriterT m) = showsUnary1 "WriterT" d m--instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where eq1 = (==)-instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where compare1 = compare-instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where readsPrec1 = readsPrec-instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where showsPrec1 = showsPrec--instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where- Compose x == Compose y = eq1 (fmap Apply x) (fmap Apply y)--instance (Functor f, Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where- compare (Compose x) (Compose y) = compare1 (fmap Apply x) (fmap Apply y)--instance (Functor f, Read1 f, Read1 g, Read a) => Read (Compose f g a) where- readsPrec = readsData $ readsUnary1 "Compose" (Compose . fmap getApply)--instance (Functor f, Show1 f, Show1 g, Show a) => Show (Compose f g a) where- showsPrec d (Compose x) = showsUnary1 "Compose" d (fmap Apply x)--instance (Functor f, Eq1 f, Eq1 g) => Eq1 (Compose f g) where eq1 = (==)-instance (Functor f, Ord1 f, Ord1 g) => Ord1 (Compose f g) where- compare1 = compare-instance (Functor f, Read1 f, Read1 g) => Read1 (Compose f g) where- readsPrec1 = readsPrec-instance (Functor f, Show1 f, Show1 g) => Show1 (Compose f g) where- showsPrec1 = showsPrec--instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) where- Pair x1 y1 == Pair x2 y2 = eq1 x1 x2 && eq1 y1 y2--instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where- compare (Pair x1 y1) (Pair x2 y2) =- compare1 x1 x2 `mappend` compare1 y1 y2--instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where- readsPrec = readsData $ readsBinary1 "Pair" Pair--instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where- showsPrec d (Pair x y) = showsBinary1 "Pair" d x y--instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where eq1 = (==)-instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where compare1 = compare-instance (Read1 f, Read1 g) => Read1 (Product f g) where readsPrec1 = readsPrec-instance (Show1 f, Show1 g) => Show1 (Product f g) where showsPrec1 = showsPrec--instance Eq a => Eq1 (Constant a) where eq1 = (==)-instance Ord a => Ord1 (Constant a) where compare1 = compare-instance Read a => Read1 (Constant a) where readsPrec1 = readsPrec-instance Show a => Show1 (Constant a) where showsPrec1 = showsPrec--instance Eq1 Identity where eq1 = (==)-instance Ord1 Identity where compare1 = compare-instance Read1 Identity where readsPrec1 = readsPrec-instance Show1 Identity where showsPrec1 = showsPrec---- Instances of Prelude classes---- kludge to get type with the same instances as g a-newtype Apply g a = Apply (g a)--getApply :: Apply g a -> g a-getApply (Apply x) = x--instance (Eq1 g, Eq a) => Eq (Apply g a) where- Apply x == Apply y = eq1 x y--instance (Ord1 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = compare1 x y--instance (Read1 g, Read a) => Read (Apply g a) where- readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]--instance (Show1 g, Show a) => Show (Apply g a) where- showsPrec d (Apply x) = showsPrec1 d x--#if MIN_VERSION_transformers(0,3,0)-instance (Eq1 f, Eq a) => Eq (Lift f a) where- Pure x1 == Pure x2 = x1 == x2- Other y1 == Other y2 = eq1 y1 y2- _ == _ = False--instance (Ord1 f, Ord a) => Ord (Lift f a) where- compare (Pure x1) (Pure x2) = compare x1 x2- compare (Pure _) (Other _) = LT- compare (Other _) (Pure _) = GT- compare (Other y1) (Other y2) = compare1 y1 y2--instance (Read1 f, Read a) => Read (Lift f a) where- readsPrec = readsData $- readsUnary "Pure" Pure `mappend` readsUnary1 "Other" Other--instance (Show1 f, Show a) => Show (Lift f a) where- showsPrec d (Pure x) = showsUnary "Pure" d x- showsPrec d (Other y) = showsUnary1 "Other" d y--instance Eq1 f => Eq1 (Lift f) where eq1 = (==)-instance Ord1 f => Ord1 (Lift f) where compare1 = compare-instance Read1 f => Read1 (Lift f) where readsPrec1 = readsPrec-instance Show1 f => Show1 (Lift f) where showsPrec1 = showsPrec--instance (Eq1 f, Eq a) => Eq (Backwards f a) where- Backwards x == Backwards y = eq1 x y--instance (Ord1 f, Ord a) => Ord (Backwards f a) where- compare (Backwards x) (Backwards y) = compare1 x y--instance (Read1 f, Read a) => Read (Backwards f a) where- readsPrec = readsData $ readsUnary1 "Backwards" Backwards--instance (Show1 f, Show a) => Show (Backwards f a) where- showsPrec d (Backwards x) = showsUnary1 "Backwards" d x--instance Eq1 f => Eq1 (Backwards f) where eq1 = (==)-instance Ord1 f => Ord1 (Backwards f) where compare1 = compare-instance Read1 f => Read1 (Backwards f) where readsPrec1 = readsPrec-instance Show1 f => Show1 (Backwards f) where showsPrec1 = showsPrec--instance (Eq1 f, Eq a) => Eq (Reverse f a) where- Reverse x == Reverse y = eq1 x y--instance (Ord1 f, Ord a) => Ord (Reverse f a) where- compare (Reverse x) (Reverse y) = compare1 x y--instance (Read1 f, Read a) => Read (Reverse f a) where- readsPrec = readsData $ readsUnary1 "Reverse" Reverse--instance (Show1 f, Show a) => Show (Reverse f a) where- showsPrec d (Reverse x) = showsUnary1 "Reverse" d x--instance (Eq1 f) => Eq1 (Reverse f) where eq1 = (==)-instance (Ord1 f) => Ord1 (Reverse f) where compare1 = compare-instance (Read1 f) => Read1 (Reverse f) where readsPrec1 = readsPrec-instance (Show1 f) => Show1 (Reverse f) where showsPrec1 = showsPrec-#endif
− 0.3/Data/Functor/Sum.hs
@@ -1,59 +0,0 @@--- |--- 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))---- | Lifted sum of functors.-data Sum f g a = InL (f a) | InR (g a)--instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where- InL x1 == InL x2 = eq1 x1 x2- InR y1 == InR y2 = eq1 y1 y2- _ == _ = False--instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where- compare (InL x1) (InL x2) = compare1 x1 x2- compare (InL _) (InR _) = LT- compare (InR _) (InL _) = GT- compare (InR y1) (InR y2) = compare1 y1 y2--instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where- readsPrec = readsData $- readsUnary1 "InL" InL `mappend` readsUnary1 "InR" InR--instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where- showsPrec d (InL x) = showsUnary1 "InL" d x- showsPrec d (InR y) = showsUnary1 "InR" d y--instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where eq1 = (==)-instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where compare1 = compare-instance (Read1 f, Read1 g) => Read1 (Sum f g) where readsPrec1 = readsPrec-instance (Show1 f, Show1 g) => Show1 (Sum f g) where showsPrec1 = showsPrec--instance (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
@@ -0,0 +1,292 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Trans.Accum+-- Copyright : (c) Nickolay Kudasov 2016+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- The lazy 'AccumT' monad transformer, which adds accumulation+-- capabilities (such as declarations or document patches) to a given monad.+--+-- This monad transformer provides append-only accumulation+-- during the computation. For more general access, use+-- "Control.Monad.Trans.State" instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Accum (+ -- * The Accum monad+ Accum,+ accum,+ runAccum,+ execAccum,+ evalAccum,+ mapAccum,+ -- * The AccumT monad transformer+ AccumT(AccumT),+ runAccumT,+ execAccumT,+ evalAccumT,+ mapAccumT,+ -- * Accum operations+ look,+ looks,+ add,+ -- * Lifting other operations+ liftCallCC,+ liftCallCC',+ liftCatch,+ liftListen,+ liftPass,+ -- * Monad transformations+ readerToAccumT,+ writerToAccumT,+ accumToStateT,+ ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.Writer (WriterT(..))+import Control.Monad.Trans.State (StateT(..))+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+import qualified Control.Monad.Fail as Fail+import Control.Monad.Fix+import Control.Monad.Signatures++#ifndef HASKELL98+import GHC.Generics+#endif++-- ---------------------------------------------------------------------------+-- | An accumulation monad parameterized by the type @w@ of output to accumulate.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+type Accum w = AccumT w Identity++-- | Construct an accumulation computation from a (result, output) pair.+-- (The inverse of 'runAccum'.)+accum :: (Monad m) => (w -> (a, w)) -> AccumT w m a+accum f = AccumT $ \ w -> return (f w)+{-# INLINE accum #-}++-- | Unwrap an accumulation computation as a (result, output) pair.+-- (The inverse of 'accum'.)+runAccum :: Accum w a -> w -> (a, w)+runAccum m = runIdentity . runAccumT m+{-# INLINE runAccum #-}++-- | Extract the output from an accumulation computation.+--+-- * @'execAccum' m w = 'snd' ('runAccum' m w)@+execAccum :: Accum w a -> w -> w+execAccum m w = snd (runAccum m w)+{-# INLINE execAccum #-}++-- | Evaluate an accumulation computation with the given initial output history+-- and return the final value, discarding the final output.+--+-- * @'evalAccum' m w = 'fst' ('runAccum' m w)@+evalAccum :: (Monoid w) => Accum w a -> w -> a+evalAccum m w = fst (runAccum m w)+{-# INLINE evalAccum #-}++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runAccum' ('mapAccum' f m) = f . 'runAccum' m@+mapAccum :: ((a, w) -> (b, w)) -> Accum w a -> Accum w b+mapAccum f = mapAccumT (Identity . f . runIdentity)+{-# INLINE mapAccum #-}++-- ---------------------------------------------------------------------------+-- | An accumulation monad parameterized by:+--+-- * @w@ - the output to accumulate.+--+-- * @m@ - The inner monad.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+--+-- This monad transformer is similar to both state and writer monad transformers.+-- Thus it can be seen as+--+-- * a restricted append-only version of a state monad transformer or+--+-- * a writer monad transformer with the extra ability to read all previous output.+newtype AccumT w m a = AccumT (w -> m (a, w))++#ifndef HASKELL98+deriving instance Generic (AccumT w m a)+#endif++-- | Unwrap an accumulation computation.+runAccumT :: AccumT w m a -> w -> m (a, w)+runAccumT (AccumT f) = f+{-# INLINE runAccumT #-}++-- | Extract the output from an accumulation computation.+--+-- * @'execAccumT' m w = 'liftM' 'snd' ('runAccumT' m w)@+execAccumT :: (Monad m) => AccumT w m a -> w -> m w+execAccumT m w = do+ ~(_, w') <- runAccumT m w+ return w'+{-# INLINE execAccumT #-}++-- | Evaluate an accumulation computation with the given initial output history+-- and return the final value, discarding the final output.+--+-- * @'evalAccumT' m w = 'liftM' 'fst' ('runAccumT' m w)@+evalAccumT :: (Monad m, Monoid w) => AccumT w m a -> w -> m a+evalAccumT m w = do+ ~(a, _) <- runAccumT m w+ return a+{-# INLINE evalAccumT #-}++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runAccumT' ('mapAccumT' f m) = f . 'runAccumT' m@+mapAccumT :: (m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b+mapAccumT f m = AccumT (f . runAccumT m)+{-# INLINE mapAccumT #-}++instance (Functor m) => Functor (AccumT w m) where+ fmap f = mapAccumT $ fmap $ \ ~(a, w) -> (f a, w)+ {-# INLINE fmap #-}++instance (Monoid w, Functor m, Monad m) => Applicative (AccumT w m) where+ pure a = AccumT $ const $ return (a, mempty)+ {-# INLINE pure #-}+ mf <*> mv = AccumT $ \ w -> do+ ~(f, w') <- runAccumT mf w+ ~(v, w'') <- runAccumT mv (w `mappend` w')+ return (f v, w' `mappend` w'')+ {-# INLINE (<*>) #-}++instance (Monoid w, Functor m, MonadPlus m) => Alternative (AccumT w m) where+ empty = AccumT $ const mzero+ {-# INLINE empty #-}+ m <|> n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w+ {-# INLINE (<|>) #-}++instance (Monoid w, Functor m, Monad m) => Monad (AccumT w m) where+ m >>= k = AccumT $ \ w -> do+ ~(a, w') <- runAccumT m w+ ~(b, w'') <- runAccumT (k a) (w `mappend` w')+ return (b, w' `mappend` w'')+ {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+ fail msg = AccumT $ const (fail msg)+ {-# INLINE fail #-}+#endif++instance (Monoid w, Functor m, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where+ fail msg = AccumT $ const (Fail.fail msg)+ {-# INLINE fail #-}++instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where+ mzero = AccumT $ const mzero+ {-# INLINE mzero #-}+ m `mplus` n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w+ {-# INLINE mplus #-}++instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where+ mfix m = AccumT $ \ w -> mfix $ \ ~(a, _) -> runAccumT (m a) w+ {-# INLINE mfix #-}++instance (Monoid w) => MonadTrans (AccumT w) where+ lift m = AccumT $ const $ do+ a <- m+ return (a, mempty)+ {-# INLINE lift #-}++instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++-- | @'look'@ is an action that fetches all the previously accumulated output.+look :: (Monoid w, Monad m) => AccumT w m w+look = AccumT $ \ w -> return (w, mempty)++-- | @'look'@ is an action that retrieves a function of the previously accumulated output.+looks :: (Monoid w, Monad m) => (w -> a) -> AccumT w m a+looks f = AccumT $ \ w -> return (f w, mempty)++-- | @'add' w@ is an action that produces the output @w@.+add :: (Monad m) => w -> AccumT w m ()+add w = accum $ const ((), w)+{-# INLINE add #-}++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original output history on entering the+-- continuation.+liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b+liftCallCC callCC f = AccumT $ \ w ->+ callCC $ \ c ->+ runAccumT (f (\ a -> AccumT $ \ _ -> c (a, w))) w+{-# INLINE liftCallCC #-}++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current output history on entering the continuation.+-- It does not satisfy the uniformity property (see "Control.Monad.Signatures").+liftCallCC' :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b+liftCallCC' callCC f = AccumT $ \ s ->+ callCC $ \ c ->+ runAccumT (f (\ a -> AccumT $ \ s' -> c (a, s'))) s+{-# INLINE liftCallCC' #-}++-- | Lift a @catchE@ operation to the new monad.+liftCatch :: Catch e m (a, w) -> Catch e (AccumT w m) a+liftCatch catchE m h =+ AccumT $ \ w -> runAccumT m w `catchE` \ e -> runAccumT (h e) w+{-# INLINE liftCatch #-}++-- | Lift a @listen@ operation to the new monad.+liftListen :: (Monad m) => Listen w m (a, s) -> Listen w (AccumT s m) a+liftListen listen m = AccumT $ \ s -> do+ ~((a, s'), w) <- listen (runAccumT m s)+ return ((a, w), s')+{-# INLINE liftListen #-}++-- | Lift a @pass@ operation to the new monad.+liftPass :: (Monad m) => Pass w m (a, s) -> Pass w (AccumT s m) a+liftPass pass m = AccumT $ \ s -> pass $ do+ ~((a, f), s') <- runAccumT m s+ return ((a, s'), f)+{-# INLINE liftPass #-}++-- | Convert a read-only computation into an accumulation computation.+readerToAccumT :: (Functor m, Monoid w) => ReaderT w m a -> AccumT w m a+readerToAccumT (ReaderT f) = AccumT $ \ w -> fmap (\ a -> (a, mempty)) (f w)+{-# INLINE readerToAccumT #-}++-- | Convert a writer computation into an accumulation computation.+writerToAccumT :: WriterT w m a -> AccumT w m a+writerToAccumT (WriterT m) = AccumT $ const $ m+{-# INLINE writerToAccumT #-}++-- | Convert an accumulation (append-only) computation into a fully+-- stateful computation.+accumToStateT :: (Functor m, Monoid s) => AccumT s m a -> StateT s m a+accumToStateT (AccumT f) =+ StateT $ \ w -> fmap (\ ~(a, w') -> (a, w `mappend` w')) (f w)+{-# INLINE accumToStateT #-}
+ 0.5/Control/Monad/Trans/Select.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}++# ifndef HASKELL98+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Trans.Select+-- Copyright : (c) Ross Paterson 2017+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Selection monad transformer, modelling search algorithms.+--+-- * Martin Escardo and Paulo Oliva.+-- "Selection functions, bar recursion and backward induction",+-- /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168.+-- <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf>+--+-- * Jules Hedges. "Monad transformers for backtracking search".+-- In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058>+-----------------------------------------------------------------------------++module Control.Monad.Trans.Select (+ -- * The Select monad+ Select,+ select,+ runSelect,+ mapSelect,+ -- * The SelectT monad transformer+ SelectT(SelectT),+ runSelectT,+ mapSelectT,+ -- * Monad transformation+ selectToContT,+ ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont++import Control.Applicative+import Control.Monad+import qualified Control.Monad.Fail as Fail+import Data.Functor.Identity++#if !defined(HASKELL98)+import Data.Typeable+#endif++#ifndef HASKELL98+import GHC.Generics+#endif++-- | Selection monad.+type Select r = SelectT r Identity++-- | Constructor for computations in the selection monad.+select :: ((a -> r) -> a) -> Select r a+select f = SelectT $ \ k -> Identity (f (runIdentity . k))+{-# INLINE select #-}++-- | Runs a @Select@ computation with a function for evaluating answers+-- to select a particular answer. (The inverse of 'select'.)+runSelect :: Select r a -> (a -> r) -> a+runSelect m k = runIdentity (runSelectT m (Identity . k))+{-# INLINE runSelect #-}++-- | Selection monad transformer.+--+-- 'SelectT' is not a functor on the category of monads, and many operations+-- cannot be lifted through it.+newtype SelectT r m a = SelectT ((a -> m r) -> m a)++#ifndef HASKELL98+deriving instance Generic (SelectT r m a)+#endif++-- | Runs a @SelectT@ computation with a function for evaluating answers+-- to select a particular answer. (The inverse of 'select'.)+runSelectT :: SelectT r m a -> (a -> m r) -> m a+runSelectT (SelectT g) = g+{-# INLINE runSelectT #-}++-- | Apply a function to transform the result of a selection computation.+-- This has a more restricted type than the @map@ operations for other+-- monad transformers, because 'SelectT' does not define a functor in+-- the category of monads.+--+-- * @'runSelectT' ('mapSelectT' f m) = f . 'runSelectT' m@+mapSelectT :: (m a -> m a) -> SelectT r m a -> SelectT r m a+mapSelectT f m = SelectT $ f . runSelectT m+{-# INLINE mapSelectT #-}++-- | Apply a function to transform the result of a selection computation.+--+-- * @'runSelect' ('mapSelect' f m) = f . 'runSelect' m@+mapSelect :: (a -> a) -> Select r a -> Select r a+mapSelect f = mapSelectT (Identity . f . runIdentity)+{-# INLINE mapSelect #-}++instance (Functor m) => Functor (SelectT r m) where+ fmap f (SelectT g) = SelectT (fmap f . g . (. f))+ {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (SelectT r m) where+ pure = lift . return+ {-# INLINE pure #-}+ SelectT gf <*> SelectT gx = SelectT $ \ k -> do+ let h f = liftM f (gx (k . f))+ f <- gf ((>>= k) . h)+ h f+ {-# INLINE (<*>) #-}+ m *> k = m >>= \_ -> k+ {-# INLINE (*>) #-}++instance (Functor m, MonadPlus m) => Alternative (SelectT r m) where+ empty = mzero+ {-# INLINE empty #-}+ (<|>) = mplus+ {-# INLINE (<|>) #-}++instance (Monad m) => Monad (SelectT r m) where+ SelectT g >>= f = SelectT $ \ k -> do+ let h x = runSelectT (f x) k+ y <- g ((>>= k) . h)+ h y+ {-# INLINE (>>=) #-}++instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where+ fail msg = lift (Fail.fail msg)+ {-# INLINE fail #-}++instance (MonadPlus m) => MonadPlus (SelectT r m) where+ mzero = SelectT (const mzero)+ {-# INLINE mzero #-}+ SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k+ {-# INLINE mplus #-}++instance MonadTrans (SelectT r) where+ lift = SelectT . const+ {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (SelectT r m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++-- | Convert a selection computation to a continuation-passing computation.+selectToContT :: (Monad m) => SelectT r m a -> ContT r m a+selectToContT (SelectT g) = ContT $ \ k -> g k >>= k
CHANGELOG.markdown view
@@ -1,12 +1,217 @@+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+ `Data.Functor.Classes.Generic`.++0.7.1 [2021.10.30]+------------------+* Backport new instances from GHC 9.2/`base-4.16`+ * `Eq1`, `Read1`, and `Show1` instances for `Complex`+ * `Eq{1,2}`, `Ord{1,2}`, `Show{1,2}`, and `Read{1,2}` instances for `(,,)`+ and `(,,,)`++0.7 [2021.07.25]+----------------+* Backport changes from `transformers-0.6.*`:+ * Remove the long-deprecated `selectToCont` function from+ `Control.Monad.Trans.Select`.+ * Backport various `Generic`, `Generic1`, and `Data` instances.+ * Backport `handleE`, `tryE`, and `finallyE` to `Control.Monad.Trans.Except`.+ * Backport explicit implementations of `(<$)`, `liftA2`, `(*>)`, and `(<*)`+ for `Control.Applicative.Backwards`.+ * Backport a lazier implementation of `(<*>)` for `Control.Applicative.Lift`.++0.6.6 [2020.09.30]+------------------+* Add `FunctorClassesDefault`, an adapter newtype suitable for `DerivingVia`,+ to `Data.Functor.Classes.Generic`.+* Fix a bug in which `readsPrec1Default`/`liftReadsPrecDefault` would parse+ empty data types too strictly.++0.6.5 [2019.05.11]+------------------+* Ensure that the backported `MonadFail` instance for `ExceptT` is available+ when built against `transformers-0.4.*`.++0.6.4 [2019.04.01]+------------------+* Use more conservative CPP to guard the backported `MonadFix` instance for+ `ListT`.++0.6.3 [2019.04.01]+------------------+* Backport changes from `transformers-0.5.6.*`:+ * Backport the `MonadFix` instance for `ListT` in+ `Control.Monad.Trans.Instances`.+ * Generalize the type of `except` in `Control.Monad.Trans.Except`.+* Backport `MonadFail` instances for `AccumT`, `Reverse`, and `SelectT` on+ pre-8.0 versions of GHC by depending on the `fail` package if necessary.+* Backport `MonadFail` instances for monad transformer types in+ `Control.Monad.Trans.Instances`.++0.6.2+-----+* `transformers-compat` now uses automatic flags instead of manual ones.+ This has a number of benefits:++ * There is no need for making several simultaneous releases to support each+ flag combination.+ * As a result, the `cabal-install` constraint solver should have a much+ easier time figuring out install-plans involving `transformers-compat`.++ Due to old `cabal-install` bugs, `cabal-install-1.16` and older may have a+ harder time installing this package, so it is recommended that you use+ `cabal-install-1.18` or later. (Or, if you must use `cabal-install-1.16` or+ older, installing `transformers-compat` with the appropriate flags should+ help.)++0.6.1.6+-------+* Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version.+ This release is configured with none of `-ftwo`, `-fthree`, `-ffour`, or `-ffive` (which works with `transformers-0.5.3` and above).++0.6.1.5+-------+* Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version.+ This release is configured with `-ffive` (which works with `transformers-0.5` up until, but not including, `transformers-0.5.3`).++0.6.1.4+-------+* Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version.+ This release is configured with `-ffour` (which works with the `transformers-0.4` series).++0.6.1.3+-------+* Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series).++0.6.1.2+-------+* Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series).++0.6.1+-----+* Fix an oversight in which the `Control.Monad.Trans.Accum` and+ `Control.Monad.Trans.Select` modules were not backported when built with the+ `-ffour` flag.++0.6.0.6+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with none of `-ftwo`, `-fthree`, `-ffour`, or `-ffive` (which works with `transformers-0.5.3` and above).++0.6.0.5+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-ffive` (which works with `transformers-0.5` up until, but not including, `transformers-0.5.3`).++0.6.0.4+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-ffour` (which works with the `transformers-0.4` series).++0.6.0.3+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series).++0.6.0.2+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series).++0.6+---+* Introduce the `Data.Functor.Classes.Generic` module, which provides functions that can generically implement methods in the `Eq1`, `Ord1`, `Read1`, and `Show1` classes (without the usual boilerplate involved).+* Introduce the `generic-deriving` flag. When enabled, `transformers-compat` will depend on the `generic-deriving` library on older versions of GHC to backport `GHC.Generics` support for `Generic` instances and the machinery in `Data.Functor.Classes.Generic`.+* Some instances were present in `Data.Functor.Sum` but not in `Control.Monad.Trans.Instances` (e.g., the `Generic`, `Typeable`, and `Data` instances for `Sum`). This has been fixed.+* Backport changes from `transformers-0.5.5`:+ * Backport the `Semigroup` instance for `Constant`+ * Add `mapSelect` and `mapSelectT`+ * Define `selectToContT` (and deprecate `selectToCont` in favor of that)+ * Define some explicit `(*>)` definitions to avoid space leaks+* Backport changes from `transformers-0.5.4` (i.e., add `Bifoldable` and `Bitraversable` instances for `Data.Functor.Constant`)+* Backport changes from `transformers-0.5.3`:+ * Backport the `Control.Monad.Trans.Accum` and `Control.Monad.Trans.Select` modules+ * Backport the `eitherToErrors` and `elimLift` functions to `Control.Applicative.Lift`+ * Backport `Bits`, `FiniteBits`, `IsString`, `Num`, `Real`, `Integral`, `Fractional`, `Floating`, `RealFrac`, and `RealFloat` instances for `Data.Functor.Identity`+ * Backport `Monad`, `MonadFail`, and `MonadPlus` instances for `Data.Functor.Reverse`+ * Backport `Eq1`, `Ord1`, `Read1`, and `Show1` instances for `Data.Proxy`+* Backport changes from `transformers-0.5.2` (i.e., add more `INLINE` annotations)+* Backport changes from `transformers-0.5.1` (i.e., add `Bounded`, `Enum`, `Ix`, and `Storable` instances for `Identity`)++0.5.1.4+-------+* Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above).++0.5.1.3+-------+* Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series).++0.5.1.2+-------+* Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series).++0.5.1+-----+* Fix a bug in which `PolyKinds` was enabled on GHC 7.4, resulting in interface file bugs on that version of GHC.++0.5.0.4+-------+* Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above).++0.5.0.3+-------+* Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series).++0.5.0.2+-------+* Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series).++0.5+---+* Update `transformers-compat` to incorporate changes from the `transformers-0.5` series. These changes include:+ * The `Data.Functor.Classes` module was completely redesigned.+ * Modules now have `Safe` or `Trustworthy` annotations.+ * Data types and type synonyms are poly-kinded when possible.+* Add `Control.Monad.Trans.Instances`, a module of orphan instances that mimic instances available in later versions of `transformers`.+ 0.4.0.4 -------+* Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above). 0.4.0.3 -------+* Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.4.0.2 --------* Each of these is a build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker.+* Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.4 ---@@ -19,14 +224,21 @@ 0.3.3.4 -------+* Versions 0.3.3.2–0.3.3.4 were a successful attempt to fix build problems caused by the cabal backtracker.+* Each of these is a build with a different set of flags configured.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above). 0.3.3.3 -------+* Versions 0.3.3.2–0.3.3.4 were a successful attempt to fix build problems caused by the cabal backtracker.+* Each of these is a build with a different set of flags configured.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.3.3.2 --------* These releases were a successful attempt to fix build problems caused by the cabal backtracker.+* Versions 0.3.3.2–0.3.3.4 were a successful attempt to fix build problems caused by the cabal backtracker. * Each of these is a build with a different set of flags configured.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.3.2 -----
− HLint.hs
@@ -1,1 +0,0 @@-ignore "Warning: Avoid lambda"
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2012 Edward Kmett+Copyright 2012-2015 Edward Kmett All rights reserved.
README.markdown view
@@ -1,11 +1,19 @@ transformers-compat =================== -[](http://travis-ci.org/ekmett/transformers-compat)+[](https://hackage.haskell.org/package/transformers-compat) [](https://github.com/ekmett/transformers-compat/actions?query=workflow%3AHaskell-CI) This provides a thin compatibility shim on top of transformers-0.2 to add the types that were added in transformers-0.3. This enables users to maintain haskell-platform compatibility, while still gaining access ot the new functionality.++Related packages+----------------+The `writer-cps-transformers` package backports the+`Control.Monad.Trans.{RWS,Writer}.CPS` modules that were introduced in+`transformers-0.5.6.0`. There are also a variety of companion packages which+backport orphan instances for these types. One example is `writer-cps-mtl`,+which backports instances of type classes from the `mtl` library. Contact Information -------------------
+ generics/Data/Functor/Classes/Generic.hs view
@@ -0,0 +1,79 @@+{-|+Module: Data.Functor.Classes.Generic+Copyright: (C) 2015-2016 Edward Kmett, Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Stability: Provisional+Portability: GHC++Functions to generically derive 'C.Eq1', 'C.Ord1', 'C.Read1', and 'C.Show1'+instances from "Data.Functor.Classes".+-}+module Data.Functor.Classes.Generic+ ( -- * Options+ Options(..)+ , defaultOptions+ , latestGHCOptions+ -- * 'Eq1'+ , liftEqDefault+ , liftEqOptions+ -- * 'Ord1'+ , liftCompareDefault+ , liftCompareOptions+ -- * 'Read1'+ , liftReadsPrecDefault+ , liftReadsPrecOptions+ -- * 'Show1'+ , liftShowsPrecDefault+ , liftShowsPrecOptions+ -- * 'GenericFunctorClasses'+ , FunctorClassesDefault(..)+ -- * Example+ -- $example+ ) where++import qualified Data.Functor.Classes as C ()+import Data.Functor.Classes.Generic.Internal++{- $example+The most straightforward way to use the defaults in this module is to use+@DerivingVia@ on GHC 8.6 or later. For example:++@+{-# LANGUAGE DeriveGeneric, DerivingVia #-}++import Data.Functor.Classes+import Data.Functor.Classes.Generic+import GHC.Generics++data Pair a = Pair a a+ deriving stock Generic1+ deriving (Eq1, Ord1, Read1, Show1)+ via FunctorClassesDefault Pair+@++If using an older version of GHC, then one can also define instances manually.+Here is an example:++@+{-# LANGUAGE DeriveGeneric #-}++import Data.Functor.Classes+import Data.Functor.Classes.Generic+import GHC.Generics++data Pair a = Pair a a deriving Generic1++instance 'C.Eq1' Pair where+ 'C.liftEq' = 'liftEqDefault'++instance 'C.Ord1' Pair where+ 'C.liftCompare' = 'liftCompareDefault'++instance 'C.Read1' Pair where+ 'C.liftReadsPrec' = 'liftReadsPrecDefault'++instance 'C.Show1' Pair where+ 'C.liftShowsPrec' = 'liftShowsPrecDefault'+@+-}
+ generics/Data/Functor/Classes/Generic/Internal.hs view
@@ -0,0 +1,1056 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE QuantifiedConstraints #-}+#endif++{-|+Module: Data.Functor.Classes.Generic+Copyright: (C) 2015-2016 Edward Kmett, Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Stability: Provisional+Portability: GHC++Internal functionality for "Data.Functor.Classes.Generic".++This is an internal module and, as such, the API is not guaranteed to remain the+same between any given release.+-}+module Data.Functor.Classes.Generic.Internal+ ( -- * Options+ Options(..)+ , defaultOptions+ , latestGHCOptions+ -- * 'Eq1'+ , liftEqDefault+ , liftEqOptions+ , GEq1(..)+ -- * 'Ord1'+ , liftCompareDefault+ , liftCompareOptions+ , GOrd1(..)+ -- * 'Read1'+ , liftReadsPrecDefault+ , liftReadsPrecOptions+ , GRead1(..)+ , GRead1Con(..)+ -- * 'Show1'+ , liftShowsPrecDefault+ , liftShowsPrecOptions+ , GShow1(..)+ , GShow1Con(..)+ -- * 'Eq'+ , eqDefault+ , GEq(..)+ -- * 'Ord'+ , compareDefault+ , GOrd(..)+ -- * 'Read'+ , readsPrecDefault+ , GRead(..)+ -- * 'Show'+ , showsPrecDefault+ , showsPrecOptions+ , GShow(..)+ -- * 'FunctorClassesDefault'+ , FunctorClassesDefault(..)+ -- * Miscellaneous types+ , ConType(..)+ , IsNullaryDataType(..)+ , IsNullaryCon(..)+ ) where++import Data.Char (isSymbol, ord)+import Data.Functor.Classes+import GHC.Exts+import GHC.Generics hiding (prec)+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(..))+import Text.Show (showListWith)+++-------------------------------------------------------------------------------+-- * Options+-------------------------------------------------------------------------------++-- | Options that further configure how the functions in+-- "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++-- | Options that match the behavior of the most recent GHC release.+latestGHCOptions :: Options+latestGHCOptions = Options++-------------------------------------------------------------------------------+-- * Eq+-------------------------------------------------------------------------------++-- | A default @('==')@ implementation for 'Generic1' instances that leverages+-- 'Eq1'.+eqDefault :: (GEq (Rep1 f a), Generic1 f) => f a -> f a -> Bool+eqDefault m n = geq (from1 m) (from1 n)++-- | Class of generic representation types that can be checked for equality.+class GEq a where+ geq :: a -> a -> Bool++instance Eq c => GEq (K1 i c p) where+ geq (K1 c) (K1 d) = c == d++instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where+ geq (a :*: b) (c :*: d) = geq a c && geq b d++instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where+ geq (L1 a) (L1 c) = geq a c+ geq (R1 b) (R1 d) = geq b d+ geq _ _ = False++instance GEq (f p) => GEq (M1 i c f p) where+ geq (M1 a) (M1 b) = geq a b++instance GEq (U1 p) where+ geq U1 U1 = True++instance GEq (V1 p) where+ geq _ _ = True++instance Eq p => GEq (Par1 p) where+ geq (Par1 a) (Par1 b) = a == b++instance (Eq1 f, Eq p) => GEq (Rec1 f p) where+ geq (Rec1 a) (Rec1 b) = eq1 a b++instance (Eq1 f, GEq (g p)) => GEq ((f :.: g) p) where+ geq (Comp1 m) (Comp1 n) = liftEq geq m n++-- Unboxed types+instance GEq (UAddr p) where+ geq = eqUAddr++instance GEq (UChar p) where+ geq = eqUChar++instance GEq (UDouble p) where+ geq = eqUDouble++instance GEq (UFloat p) where+ geq = eqUFloat++instance GEq (UInt p) where+ geq = eqUInt++instance GEq (UWord p) where+ geq = eqUWord++-------------------------------------------------------------------------------+-- * Eq1+-------------------------------------------------------------------------------++-- | A sensible default 'liftEq' implementation for 'Generic1' instances.+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 (Rep1 f), Generic1 f)+ => Options -> (a -> b -> Bool) -> f a -> f b -> Bool+liftEqOptions _ f m n = gliftEq f (from1 m) (from1 n)++-- | Class of generic representation types that can lift equality through unary+-- type constructors.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Eq a => GEq (t a)) =>+#endif+ GEq1 t where+ gliftEq :: (a -> b -> Bool) -> t a -> t b -> Bool++instance Eq c => GEq1 (K1 i c) where+ gliftEq _ (K1 c) (K1 d) = c == d++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 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 f => GEq1 (M1 i c f) where+ gliftEq f (M1 a) (M1 b) = gliftEq f a b++instance GEq1 U1 where+ gliftEq _ U1 U1 = True++instance GEq1 V1 where+ gliftEq _ _ _ = True++instance GEq1 Par1 where+ gliftEq f (Par1 a) (Par1 b) = f a b++instance Eq1 f => GEq1 (Rec1 f) where+ gliftEq f (Rec1 a) (Rec1 b) = liftEq f a b++instance (Eq1 f, GEq1 g) => GEq1 (f :.: g) where+ gliftEq f (Comp1 m) (Comp1 n) = liftEq (gliftEq f) m n++-- Unboxed types+instance GEq1 UAddr where+ gliftEq _ = eqUAddr++instance GEq1 UChar where+ gliftEq _ = eqUChar++instance GEq1 UDouble where+ gliftEq _ = eqUDouble++instance GEq1 UFloat where+ gliftEq _ = eqUFloat++instance GEq1 UInt where+ gliftEq _ = eqUInt++instance GEq1 UWord where+ gliftEq _ = eqUWord++eqUAddr :: UAddr p -> UAddr q -> Bool+eqUAddr (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)++eqUChar :: UChar p -> UChar q -> Bool+eqUChar (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)++eqUDouble :: UDouble p -> UDouble q -> Bool+eqUDouble (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)++eqUFloat :: UFloat p -> UFloat q -> Bool+eqUFloat (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)++eqUInt :: UInt p -> UInt q -> Bool+eqUInt (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)++eqUWord :: UWord p -> UWord q -> Bool+eqUWord (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2)++-------------------------------------------------------------------------------+-- * Ord+-------------------------------------------------------------------------------++-- | A default 'compare' implementation for 'Generic1' instances that leverages+-- 'Ord1'.+compareDefault :: (GOrd (Rep1 f a), Generic1 f) => f a -> f a -> Ordering+compareDefault m n = gcompare (from1 m) (from1 n)++-- | Class of generic representation types that can be totally ordered.+class GEq a => GOrd a where+ gcompare :: a -> a -> Ordering++instance Ord c => GOrd (K1 i c p) where+ gcompare (K1 c) (K1 d) = compare c d++instance (GOrd (f p), GOrd (g p)) => GOrd ((f :*: g) p) where+ gcompare (a :*: b) (c :*: d) = gcompare a c `mappend` gcompare b d++instance (GOrd (f p), GOrd (g p)) => GOrd ((f :+: g) p) where+ gcompare (L1 a) (L1 c) = gcompare a c+ gcompare L1{} R1{} = LT+ gcompare R1{} L1{} = GT+ gcompare (R1 b) (R1 d) = gcompare b d++instance GOrd (f p) => GOrd (M1 i c f p) where+ gcompare (M1 a) (M1 b) = gcompare a b++instance GOrd (U1 p) where+ gcompare U1 U1 = EQ++instance GOrd (V1 p) where+ gcompare _ _ = EQ++instance Ord p => GOrd (Par1 p) where+ gcompare (Par1 a) (Par1 b) = compare a b++instance (Ord1 f, Ord p) => GOrd (Rec1 f p) where+ gcompare (Rec1 a) (Rec1 b) = compare1 a b++instance (Ord1 f, GOrd (g p)) => GOrd ((f :.: g) p) where+ gcompare (Comp1 m) (Comp1 n) = liftCompare gcompare m n++-- Unboxed types+instance GOrd (UAddr p) where+ gcompare = compareUAddr++instance GOrd (UChar p) where+ gcompare = compareUChar++instance GOrd (UDouble p) where+ gcompare = compareUDouble++instance GOrd (UFloat p) where+ gcompare = compareUFloat++instance GOrd (UInt p) where+ gcompare = compareUInt++instance GOrd (UWord p) where+ gcompare = compareUWord++-------------------------------------------------------------------------------+-- * Ord1+-------------------------------------------------------------------------------++-- | A sensible default 'liftCompare' implementation for 'Generic1' instances.+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 (Rep1 f), Generic1 f)+ => Options -> (a -> b -> Ordering) -> f a -> f b -> Ordering+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 t+#if __GLASGOW_HASKELL__ >= 806+ , forall a. Ord a => GOrd (t a)+#endif+ ) => GOrd1 t where+ gliftCompare :: (a -> b -> Ordering) -> t a -> t b -> Ordering++instance Ord c => GOrd1 (K1 i c) where+ gliftCompare _ (K1 c) (K1 d) = compare c d++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 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 f => GOrd1 (M1 i c f) where+ gliftCompare f (M1 a) (M1 b) = gliftCompare f a b++instance GOrd1 U1 where+ gliftCompare _ U1 U1 = EQ++instance GOrd1 V1 where+ gliftCompare _ _ _ = EQ++instance GOrd1 Par1 where+ gliftCompare f (Par1 a) (Par1 b) = f a b++instance Ord1 f => GOrd1 (Rec1 f) where+ gliftCompare f (Rec1 a) (Rec1 b) = liftCompare f a b++instance (Ord1 f, GOrd1 g) => GOrd1 (f :.: g) where+ gliftCompare f (Comp1 m) (Comp1 n) = liftCompare (gliftCompare f) m n++-- Unboxed types+instance GOrd1 UAddr where+ gliftCompare _ = compareUAddr++instance GOrd1 UChar where+ gliftCompare _ = compareUChar++instance GOrd1 UDouble where+ gliftCompare _ = compareUDouble++instance GOrd1 UFloat where+ gliftCompare _ = compareUFloat++instance GOrd1 UInt where+ gliftCompare _ = compareUInt++instance GOrd1 UWord where+ gliftCompare _ = compareUWord++compareUAddr :: UAddr p -> UAddr q -> Ordering+compareUAddr (UAddr a1) (UAddr a2) = primCompare (eqAddr# a1 a2) (leAddr# a1 a2)++compareUChar :: UChar p -> UChar q -> Ordering+compareUChar (UChar c1) (UChar c2) = primCompare (eqChar# c1 c2) (leChar# c1 c2)++compareUDouble :: UDouble p -> UDouble q -> Ordering+compareUDouble (UDouble d1) (UDouble d2) = primCompare (d1 ==## d2) (d1 <=## d2)++compareUFloat :: UFloat p -> UFloat q -> Ordering+compareUFloat (UFloat f1) (UFloat f2) = primCompare (eqFloat# f1 f2) (leFloat# f1 f2)++compareUInt :: UInt p -> UInt q -> Ordering+compareUInt (UInt i1) (UInt i2) = primCompare (i1 ==# i2) (i1 <=# i2)++compareUWord :: UWord p -> UWord q -> Ordering+compareUWord (UWord w1) (UWord w2) = primCompare (eqWord# w1 w2) (leWord# w1 w2)++primCompare :: Int# -> Int# -> Ordering+primCompare eq le = if isTrue# eq then EQ+ else if isTrue# le then LT+ else GT++-------------------------------------------------------------------------------+-- * Read+-------------------------------------------------------------------------------++-- | A default 'readsPrec' implementation for 'Generic1' instances that leverages+-- 'Read1'.+readsPrecDefault :: (GRead (Rep1 f a), Generic1 f) => Int -> ReadS (f a)+readsPrecDefault p = readPrec_to_S (fmap to1 greadPrec) p++-- | Class of generic representation types that can be parsed from a 'String'.+class GRead a where+ greadPrec :: ReadPrec a++instance (GRead (f p), IsNullaryDataType f) => GRead (D1 d f p) where+ greadPrec = d1ReadPrec greadPrec++instance GRead (V1 p) where+ greadPrec = pfail++instance (GRead (f p), GRead (g p)) => GRead ((f :+: g) p) where+ greadPrec = fmap L1 greadPrec +++ fmap R1 greadPrec++instance (Constructor c, GReadCon (f p), IsNullaryCon f) => GRead (C1 c f p) where+ greadPrec = c1ReadPrec greadPrecCon++-- | Class of generic representation types that can be parsed from a 'String',+-- and for which the 'ConType' has been determined.+class GReadCon a where+ greadPrecCon :: ConType -> ReadPrec a++instance GReadCon (U1 p) where+ greadPrecCon _ = return U1++instance Read c => GReadCon (K1 i c p) where+ greadPrecCon _ = coerceK1 readPrec++instance (Selector s, GReadCon (f p)) => GReadCon (S1 s f p) where+ greadPrecCon = s1ReadPrec . greadPrecCon++instance (GReadCon (f p), GReadCon (g p)) => GReadCon ((f :*: g) p) where+ greadPrecCon t = productReadPrec t (greadPrecCon t) (greadPrecCon t)++instance Read p => GReadCon (Par1 p) where+ greadPrecCon _ = coercePar1 readPrec++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)++instance (Read1 f, GReadCon (g p)) => GReadCon ((f :.: g) p) where+ greadPrecCon t = coerceComp1 $ readS_to_Prec $+ liftReadsPrec (readPrec_to_S grpc)+ (readPrec_to_S (list grpc) 0)+ where+ grpc = greadPrecCon t++-------------------------------------------------------------------------------+-- * Read1+-------------------------------------------------------------------------------++-- | A sensible default 'liftReadsPrec' implementation for 'Generic1' instances.+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 (Rep1 f), Generic1 f)+ => Options -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)+liftReadsPrecOptions _ rp rl p =+ readPrec_to_S (fmap to1 $ gliftReadPrec+ (readS_to_Prec rp)+ (readS_to_Prec (const rl))) p++coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)+coerceM1 = coerce++coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)+coercePar1 = coerce++coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)+coerceRec1 = coerce++coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((f :.: g) a)+coerceComp1 = coerce++coerceK1 :: ReadPrec c -> ReadPrec (K1 i c p)+coerceK1 = coerce++isSymVar :: String -> Bool+isSymVar "" = False+isSymVar (c:_) = startsVarSym c++startsVarSym :: Char -> Bool+startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids++startsVarSymASCII :: Char -> Bool+startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"++snocView :: [a] -> Maybe ([a],a)+ -- Split off the last element+snocView [] = Nothing+snocView xs = go [] xs+ where+ -- Invariant: second arg is non-empty+ go acc [a] = Just (reverse acc, a)+ go acc (a:as) = go (a:acc) as+ go _ [] = error "Util: snocView"++identHLexemes :: String -> [Lexeme]+identHLexemes s | Just (ss, '#') <- snocView s = [Ident ss, Symbol "#"]+ | otherwise = [Ident s]++-- | Class of generic representation types for unary type constructors that can+-- be parsed from a 'String'.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Read a => GRead (f a)) =>+#endif+ GRead1 f where+ gliftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)++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)+d1ReadPrec rp = coerceM1 $ parensIfNonNullary rp+ where+ x :: f p+ x = undefined++ parensIfNonNullary :: ReadPrec a -> ReadPrec a+ parensIfNonNullary = if isNullaryDataType x+ then id+ else parens++instance GRead1 V1 where+ gliftReadPrec _ _ = pfail++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 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)+c1ReadPrec rpc =+ coerceM1 $ case fixity of+ Prefix -> precIfNonNullary $ do+ if conIsTuple c+ then return ()+ else let cn = conName c+ in if isInfixDataCon cn+ then readSurround '(' (expectP (Symbol cn)) ')'+ else mapM_ expectP $ identHLexemes cn+ readBraces t (rpc t)+ Infix _ m -> prec m $ rpc t+ where+ c :: C1 c f p+ c = undefined++ x :: f p+ x = undefined++ fixity :: Fixity+ fixity = conFixity c++ precIfNonNullary :: ReadPrec a -> ReadPrec a+ precIfNonNullary = if isNullaryCon x+ then id+ else prec (if conIsRecord c+ then appPrec1+ else appPrec)++ t :: ConType+ t = if conIsRecord c+ then Rec+ else case conIsTuple c of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf $ conName c++readBraces :: ConType -> ReadPrec a -> ReadPrec a+readBraces Rec r = readSurround '{' r '}'+readBraces Tup r = paren r+readBraces Pref r = r+readBraces (Inf _) r = r++readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a+readSurround c1 r c2 = do+ expectP (Punc [c1])+ r' <- r+ expectP (Punc [c2])+ return r'++-- | Class of generic representation types for unary type constructors that+-- can be parsed from a 'String', and for which the 'ConType' has been+-- determined.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Read a => GReadCon (f a)) =>+#endif+ GRead1Con f where+ gliftReadPrecCon :: ConType -> ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)++instance GRead1Con U1 where+ gliftReadPrecCon _ _ _ = return U1++instance Read c => GRead1Con (K1 i c) where+ gliftReadPrecCon _ _ _ = coerceK1 readPrec++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)+s1ReadPrec rp+ | selectorName == "" = coerceM1 $ step rp+ | otherwise = coerceM1 $ do+ mapM_ expectP $ readLblLexemes selectorName+ expectP (Punc "=")+ reset rp+ where+ selectorName :: String+ selectorName = selName (undefined :: S1 s f p)++ readLblLexemes :: String -> [Lexeme]+ readLblLexemes lbl | isSymVar lbl+ = [Punc "(", Symbol lbl, Punc ")"]+ | otherwise+ = identHLexemes lbl++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+ l <- rpf+ case t of+ Rec -> expectP (Punc ",")+ Inf o -> infixPrec o+ Tup -> expectP (Punc ",")+ Pref -> return ()+ r <- rpg+ return (l :*: r)+ where+ infixPrec :: String -> ReadPrec ()+ infixPrec o = if isInfixDataCon o+ then expectP (Symbol o)+ else mapM_ expectP $+ [Punc "`"] ++ identHLexemes o ++ [Punc "`"]++instance GRead1Con Par1 where+ gliftReadPrecCon _ rp _ = coercePar1 rp++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 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 rp rl++-------------------------------------------------------------------------------+-- * Show+-------------------------------------------------------------------------------++-- | A default 'showsPrec' implementation for 'Generic1' instances that leverages+-- 'Show1'.+showsPrecDefault :: (GShow (Rep1 f a), Generic1 f)+ => Int -> f a -> ShowS+showsPrecDefault = showsPrecOptions defaultOptions++-- | 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 _ p = gshowsPrec p . from1++-- | Class of generic representation types that can be converted to a 'String'.+class GShow a where+ gshowsPrec :: Int -> a -> ShowS++instance GShow (f p) => GShow (D1 d f p) where+ gshowsPrec p (M1 x) = gshowsPrec p x++instance GShow (V1 p) where+ gshowsPrec = v1ShowsPrec++instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where+ 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 = 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 :: ConType -> Int -> a -> ShowS++instance GShowCon (U1 p) where+ gshowsPrecCon _ _ U1 = id++instance Show c => GShowCon (K1 i c p) where+ gshowsPrecCon _ p (K1 x) = showsPrec p x++instance (Selector s, GShowCon (f p)) => GShowCon (S1 s f p) where+ gshowsPrecCon = s1ShowsPrec . gshowsPrecCon++instance (GShowCon (f p), GShowCon (g p)) => GShowCon ((f :*: g) p) where+ gshowsPrecCon t = productShowsPrec (gshowsPrecCon t) (gshowsPrecCon t) t++instance Show p => GShowCon (Par1 p) where+ gshowsPrecCon _ p (Par1 x) = showsPrec p x++instance (Show1 f, Show p) => GShowCon (Rec1 f p) where+ gshowsPrecCon _ p (Rec1 x) = liftShowsPrec showsPrec showList p x++instance (Show1 f, GShowCon (g p)) => GShowCon ((f :.: g) p) where+ gshowsPrecCon t p (Comp1 x) =+ let glspc = gshowsPrecCon t+ in liftShowsPrec glspc (showListWith (glspc 0)) p x++instance GShowCon (UChar p) where+ gshowsPrecCon _ = uCharShowsPrec++instance GShowCon (UDouble p) where+ gshowsPrecCon _ = uDoubleShowsPrec++instance GShowCon (UFloat p) where+ gshowsPrecCon _ = uFloatShowsPrec++instance GShowCon (UInt p) where+ gshowsPrecCon _ = uIntShowsPrec++instance GShowCon (UWord p) where+ gshowsPrecCon _ = uWordShowsPrec++-------------------------------------------------------------------------------+-- * Show1+-------------------------------------------------------------------------------++-- | A sensible default 'liftShowsPrec' implementation for 'Generic1' instances.+liftShowsPrecDefault :: (GShow1 (Rep1 f), Generic1 f)+ => (Int -> a -> ShowS) -> ([a] -> ShowS)+ -> Int -> f a -> ShowS+liftShowsPrecDefault = liftShowsPrecOptions defaultOptions++-- | 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 _ sp sl p = gliftShowsPrec sp sl p . from1++-- | Class of generic representation types for unary type constructors that can+-- be converted to a 'String'.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Show a => GShow (f a)) =>+#endif+ GShow1 f where+ gliftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS)+ -> Int -> f a -> ShowS++instance GShow1 f => GShow1 (D1 d f) where+ gliftShowsPrec sp sl p (M1 x) = gliftShowsPrec sp sl p x++instance GShow1 V1 where+ gliftShowsPrec _ _ = v1ShowsPrec++v1ShowsPrec :: Int -> V1 p -> ShowS+v1ShowsPrec _ x = case x of {}++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 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+c1ShowsPrec sp p c@(M1 x) = case fixity of+ Prefix -> showParen ( p > appPrec+ && not (isNullaryCon x || conIsTuple c)+ ) $+ (if conIsTuple c+ then id+ else let cn = conName c+ in showParen (isInfixDataCon cn) (showString cn))+ . (if isNullaryCon x || conIsTuple c+ then id+ else showChar ' ')+ . showBraces t (sp t appPrec1 x)+ Infix _ m -> showParen (p > m) $ sp t (m+1) x+ where+ fixity :: Fixity+ fixity = conFixity c++ t :: ConType+ t = if conIsRecord c+ then Rec+ else case conIsTuple c of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf $ conName c++showBraces :: ConType -> ShowS -> ShowS+showBraces Rec b = showChar '{' . b . showChar '}'+showBraces Tup b = showChar '(' . b . showChar ')'+showBraces Pref b = b+showBraces (Inf _) b = b++-- | Class of generic representation types for unary type constructors that can+-- be converted to a 'String', and for which the 'ConType' has been determined.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Show a => GShowCon (f a)) =>+#endif+ GShow1Con f where+ gliftShowsPrecCon :: ConType -> (Int -> a -> ShowS) -> ([a] -> ShowS)+ -> Int -> f a -> ShowS++instance GShow1Con U1 where+ gliftShowsPrecCon _ _ _ _ U1 = id++instance Show c => GShow1Con (K1 i c) where+ gliftShowsPrecCon _ _ _ p (K1 x) = showsPrec p x++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)+ | selName sel == "" = sp p x+ | otherwise = infixRec+ . showString " = "+ . sp 0 x+ where+ infixRec :: ShowS+ infixRec | isSymVar selectorName+ = showChar '(' . showString selectorName . showChar ')'+ | otherwise+ = showString selectorName++ selectorName :: String+ selectorName = selName sel++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)+ -> ConType -> Int -> (f :*: g) p -> ShowS+productShowsPrec spf spg t p (a :*: b) =+ case t of+ Rec -> spf 0 a+ . showString ", "+ . spg 0 b++ Inf o -> spf p a+ . showSpace+ . infixOp o+ . showSpace+ . spg p b++ Tup -> spf 0 a+ . showChar ','+ . spg 0 b++ Pref -> spf p a+ . showSpace+ . spg p b+ where+ infixOp :: String -> ShowS+ infixOp o = if isInfixDataCon o+ then showString o+ else showChar '`' . showString o . showChar '`'++instance GShow1Con Par1 where+ gliftShowsPrecCon _ sp _ p (Par1 x) = sp p x++instance Show1 f => GShow1Con (Rec1 f) where+ gliftShowsPrecCon _ sp sl p (Rec1 x) = liftShowsPrec sp sl p x++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++instance GShow1Con UChar where+ gliftShowsPrecCon _ _ _ = uCharShowsPrec++instance GShow1Con UDouble where+ gliftShowsPrecCon _ _ _ = uDoubleShowsPrec++instance GShow1Con UFloat where+ gliftShowsPrecCon _ _ _ = uFloatShowsPrec++instance GShow1Con UInt where+ gliftShowsPrecCon _ _ _ = uIntShowsPrec++instance GShow1Con UWord where+ gliftShowsPrecCon _ _ _ = uWordShowsPrec++uCharShowsPrec :: Int -> UChar p -> ShowS+uCharShowsPrec p (UChar c) = shows (C# c) . oneHash++uDoubleShowsPrec :: Int -> UDouble p -> ShowS+uDoubleShowsPrec p (UDouble d) = shows (D# d) . twoHash++uFloatShowsPrec :: Int -> UFloat p -> ShowS+uFloatShowsPrec p (UFloat f) = shows (F# f) . oneHash++uIntShowsPrec :: Int -> UInt p -> ShowS+uIntShowsPrec p (UInt i) = shows (I# i) . oneHash++uWordShowsPrec :: Int -> UWord p -> ShowS+uWordShowsPrec p (UWord w) = shows (W# w) . twoHash++oneHash, twoHash :: ShowS+oneHash = showChar '#'+twoHash = showString "##"++-------------------------------------------------------------------------------+-- * GenericFunctorClasses+-------------------------------------------------------------------------------++-- | An adapter newtype, suitable for @DerivingVia@. Its 'Eq1', 'Ord1',+-- 'Read1', and 'Show1' instances leverage 'Generic1'-based defaults.+newtype FunctorClassesDefault f a =+ FunctorClassesDefault { getFunctorClassesDefault :: f a }++instance (GEq1 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where+ liftEq f (FunctorClassesDefault x) (FunctorClassesDefault y) = liftEqDefault f x y+instance (GOrd1 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where+ liftCompare f (FunctorClassesDefault x) (FunctorClassesDefault y) = liftCompareDefault f x y+instance (GRead1 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where+ liftReadsPrec rp rl p = coerceFCD (liftReadsPrecDefault rp rl p)+instance (GShow1 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where+ liftShowsPrec sp sl p (FunctorClassesDefault x) = liftShowsPrecDefault sp sl p x++instance (GEq (Rep1 f a), Generic1 f) => Eq (FunctorClassesDefault f a) where+ FunctorClassesDefault x == FunctorClassesDefault y = eqDefault x y+instance (GOrd (Rep1 f a), Generic1 f) => Ord (FunctorClassesDefault f a) where+ compare (FunctorClassesDefault x) (FunctorClassesDefault y) = compareDefault x y+instance (GRead (Rep1 f a), Generic1 f) => Read (FunctorClassesDefault f a) where+ readsPrec p = coerceFCD (readsPrecDefault p)+instance (GShow (Rep1 f a), Generic1 f) => Show (FunctorClassesDefault f a) where+ showsPrec p (FunctorClassesDefault x) = showsPrecDefault p x++coerceFCD :: ReadS (f a) -> ReadS (FunctorClassesDefault f a)+coerceFCD = coerce++-------------------------------------------------------------------------------+-- * Shared code+-------------------------------------------------------------------------------++-- | Whether a constructor is a record ('Rec'), a tuple ('Tup'), is prefix ('Pref'),+-- or infix ('Inf').+data ConType = Rec | Tup | Pref | Inf String++conIsTuple :: Constructor c => C1 c f p -> Bool+conIsTuple = isTupleString . conName++isTupleString :: String -> Bool+isTupleString ('(':',':_) = True+isTupleString _ = False++isInfixDataCon :: String -> Bool+isInfixDataCon (':':_) = True+isInfixDataCon _ = False++-- | Class of generic representation types that represent a data type with+-- zero or more constructors.+class IsNullaryDataType f where+ -- | Returns 'True' if the data type has no constructors.+ isNullaryDataType :: f a -> Bool++instance IsNullaryDataType (f :+: g) where+ isNullaryDataType _ = False++instance IsNullaryDataType (C1 c f) where+ isNullaryDataType _ = False++-- | Class of generic representation types that represent a constructor with+-- zero or more fields.+class IsNullaryCon f where+ -- | Returns 'True' if the constructor has no fields.+ isNullaryCon :: f a -> Bool++instance IsNullaryDataType V1 where+ isNullaryDataType _ = True++instance IsNullaryCon U1 where+ isNullaryCon _ = True++instance IsNullaryCon Par1 where+ isNullaryCon _ = False++instance IsNullaryCon (K1 i c) where+ isNullaryCon _ = False++instance IsNullaryCon f => IsNullaryCon (S1 s f) where+ isNullaryCon (M1 x) = isNullaryCon x++instance IsNullaryCon (Rec1 f) where+ isNullaryCon _ = False++instance IsNullaryCon (f :*: g) where+ isNullaryCon _ = False++instance IsNullaryCon (f :.: g) where+ isNullaryCon _ = False++instance IsNullaryCon UChar where+ isNullaryCon _ = False++instance IsNullaryCon UDouble where+ isNullaryCon _ = False++instance IsNullaryCon UFloat where+ isNullaryCon _ = False++instance IsNullaryCon UInt where+ isNullaryCon _ = False++instance IsNullaryCon UWord where+ isNullaryCon _ = False
+ src/Control/Monad/Trans/Instances.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE CPP #-}++#ifndef HASKELL98+{-# 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/GenericsSpec.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+module GenericsSpec (main, spec) where++import Data.Functor.Classes+import Data.Proxy (Proxy(..))++import GenericsTypes++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary)++import Text.Read (minPrec)++main :: IO ()+main = hspec spec++prop_Eq :: (Eq a, Eq (f a), Eq1 f) => f a -> f a -> Expectation+prop_Eq x y = (x == y) `shouldBe` eq1 x y++eqSpec :: forall f a. (Arbitrary (f a), Show (f a),+ Eq a, Eq (f a), Eq1 f)+ => Proxy (f a) -> Spec+eqSpec _ = prop "has a valid Eq1 instance" (prop_Eq :: f a -> f a -> Expectation)++prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Expectation+prop_Ord x y = compare x y `shouldBe` compare1 x y++ordSpec :: forall f a. (Arbitrary (f a), Show (f a),+ Ord a, Ord (f a), Ord1 f)+ => Proxy (f a) -> Spec+ordSpec _ = prop "has a valid Ord1 instance" (prop_Ord :: f a -> f a -> Expectation)++-- Adapted from the definition of readEither+readEither' :: String -> (Int -> ReadS a) -> Either String a+readEither' s rs =+ case [ x | (x,"") <- rs minPrec s ] of+ [x] -> Right x+ [] -> Left "read': no parse"+ _ -> Left "read': ambiguous parse"++read' :: String -> (Int -> ReadS a) -> a+read' s = either error id . readEither' s++prop_Read :: forall f a. (Read a, Read (f a), Read1 f,+ Eq (f a), Show (f a))+ => f a -> Expectation+prop_Read x = readArb readsPrec `shouldBe` readArb readsPrec1+ where+ readArb :: (Int -> ReadS (f a)) -> f a+ readArb = read' (show x)++readSpec :: forall f a. (Arbitrary (f a), Eq (f a), Show (f a),+ Read a, Read (f a), Read1 f)+ => Proxy (f a) -> Spec+readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Expectation)++prop_Show :: (Show a, Show (f a), Show1 f) => Int -> f a -> Expectation+prop_Show p x = showsPrec p x "" `shouldBe` showsPrec1 p x ""++showSpec :: forall f a. (Arbitrary (f a), Show a, Show (f a), Show1 f)+ => Proxy (f a) -> Spec+showSpec _ = prop "has a valid Show1 instance" (prop_Show :: Int -> f a -> Expectation)++classes1Spec :: forall f a. (Arbitrary (f a),+ Ord a, Ord (f a), Ord1 f,+ Read a, Read (f a), Read1 f,+ Show a, Show (f a), Show1 f)+ => String -> Proxy (f a) -> Spec+classes1Spec str proxy =+ describe str $ do eqSpec proxy+ ordSpec proxy+ readSpec proxy+ showSpec proxy++spec :: Spec+spec = parallel $ do+ classes1Spec "TestParam" (Proxy :: Proxy (TestParam Int))+ classes1Spec "T#" (Proxy :: Proxy (T# Int))+ classes1Spec "Infix" (Proxy :: Proxy (Infix Int))+ classes1Spec "GADT" (Proxy :: Proxy (GADT Int))+ classes1Spec "Record" (Proxy :: Proxy (Record Int))+ describe "Prim" $ do+ let proxy :: Proxy (Prim Int)+ proxy = Proxy+ eqSpec proxy+ ordSpec proxy+ showSpec proxy+ describe "Empty" $ do+ let proxy :: Proxy (Empty Int)+ proxy = Proxy+ eqSpec proxy+ ordSpec proxy+ it "should fail to parse eagerly" $ do+ let readEmpty :: String -> (Int -> ReadS (Empty Int)) -> Either String (Empty Int)+ readEmpty = readEither'+ readEmpty "" readsPrec `shouldBe` readEmpty "" readsPrec1+ readEmpty (error "boom") readsPrec `shouldBe` readEmpty (error "boom") readsPrec1
+ tests/GenericsTypes.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module GenericsTypes where++import Data.Functor.Classes+import Data.Functor.Classes.Generic++import GHC.Generics (Generic1)+import GHC.Exts++import Test.QuickCheck (Arbitrary(..), oneof)++#if __GLASGOW_HASKELL__ < 804+import Data.Eq.Deriving (deriveEq)+import Data.Ord.Deriving (deriveOrd)+import Generics.Deriving.TH (deriveAll1)+import Text.Show.Deriving (deriveShow)+#endif++#if __GLASGOW_HASKELL__ < 806+import Text.Read.Deriving (deriveRead)+#endif+++data TestParam a = TestParam a (Maybe a) (Maybe (Maybe a))+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (TestParam a) where+ arbitrary = TestParam <$> arbitrary <*> arbitrary <*> arbitrary++data Prim a = Prim a Char# Double# Int# Float# Word#+ deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (Prim a) where+ arbitrary = do+ a <- arbitrary+ C# c <- arbitrary+ D# d <- arbitrary+ I# i <- arbitrary+ F# f <- arbitrary+ W# w <- arbitrary+ return $ Prim a c d i f w++data T# a = MkT1# a+ | MkT2# { getT2# :: a, (##) :: a }+ | a `MkT3#` a+ deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (T# a) where+ arbitrary = oneof [ MkT1# <$> arbitrary+ , MkT2# <$> arbitrary <*> arbitrary+ , MkT3# <$> arbitrary <*> arbitrary+ ]++infixl 3 :!:+infix 4 :@:+infixr 5 `Backticks`+infixr 6 `FakeInfix`+data Infix a = (:!:) a Double+ | a :@: ()+ | a `Backticks` Bool+ | FakeInfix a Int+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (Infix a) where+ arbitrary = oneof [ (:!:) <$> arbitrary <*> arbitrary+ , (:@:) <$> arbitrary <*> arbitrary+ , Backticks <$> arbitrary <*> arbitrary+ , FakeInfix <$> arbitrary <*> arbitrary+ ]++infixr 1 :., :..., :....+data GADT a where+ (:.) :: b -> () -> GADT b+ (:..) :: c -> Bool -> GADT c+ (:...) :: d -> Double -> Int -> GADT d+ (:....) :: { gadt1 :: e, gadt2 :: Char } -> GADT e+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (GADT a) where+ arbitrary = oneof [ (:.) <$> arbitrary <*> arbitrary+ , (:..) <$> arbitrary <*> arbitrary+ , (:...) <$> arbitrary <*> arbitrary <*> arbitrary+ , (:....) <$> arbitrary <*> arbitrary+ ]++infixl 4 :%:+data Record a = Prefix { rec1 :: Int, rec2 :: a }+ | Int :%: a+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (Record a) where+ arbitrary = oneof [ Prefix <$> arbitrary <*> arbitrary+ , (:%:) <$> arbitrary <*> arbitrary+ ]++data Empty a++instance Arbitrary (Empty a) where+ arbitrary = return $ error "Arbitrary Empty"++#if __GLASGOW_HASKELL__ == 804+-- Workaround for GHC Trac #14918+$(deriveRead ''T#)+#else+deriving instance Read a => Read (T# a)+#endif++#if __GLASGOW_HASKELL__ >= 804+deriving instance Eq (Empty a)+deriving instance Ord (Empty a)+deriving instance Read (Empty a)+deriving instance Show (Empty a)+deriving instance Generic1 Empty+#else+$(deriveEq ''Empty)+$(deriveOrd ''Empty)+$(deriveRead ''Empty)+$(deriveShow ''Empty)+$(deriveAll1 ''Empty)+#endif++deriving instance Generic1 TestParam+deriving instance Generic1 T#+deriving instance Generic1 Infix+deriving instance Generic1 GADT+deriving instance Generic1 Record++deriving instance Generic1 Prim++#define CLASS1_INSTANCE(class,type,method,impl) \+instance class type where { method = impl }; \++#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) \+ORD1_INSTANCE(type) \+READ1_INSTANCE(type) \+SHOW1_INSTANCE(type) \++CLASS1_INSTANCES(TestParam)+CLASS1_INSTANCES(T#)+CLASS1_INSTANCES(Infix)+CLASS1_INSTANCES(GADT)+CLASS1_INSTANCES(Record)+CLASS1_INSTANCES(Empty)++EQ1_INSTANCE(Prim)+ORD1_INSTANCE(Prim)+SHOW1_INSTANCE(Prim)
+ tests/LICENSE view
@@ -0,0 +1,30 @@+Copyright 2012-2015 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/transformers-compat-tests.cabal view
@@ -0,0 +1,58 @@+name: transformers-compat-tests+category: Compatibility+version: 0.1+license: BSD3+cabal-version: >= 1.10+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+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 == 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.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: https://github.com/ekmett/transformers-compat.git++flag tests+ default: True+ description: Enable the tests.++test-suite spec+ if !flag(tests)+ buildable: False++ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: GenericsSpec+ GenericsTypes+ 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+ default-language: Haskell2010
transformers-compat.cabal view
@@ -1,92 +1,127 @@ name: transformers-compat category: Compatibility-version: 0.4.0.4+version: 0.8 license: BSD3-cabal-version: >= 1.8+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-copyright: Copyright (C) 2012 Edward A. Kmett-synopsis: A small compatibility shim exposing the new types from transformers 0.3 and 0.4 to older Haskell platforms.+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 and 0.4 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.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.8.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.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:- .travis.yml .ghci .gitignore+ .hlint.yaml .vim.custom config- HLint.hs+ tests/*.hs+ tests/LICENSE+ tests/transformers-compat-tests.cabal README.markdown CHANGELOG.markdown source-repository head type: git- location: git://github.com/ekmett/transformers-compat.git+ location: https://github.com/ekmett/transformers-compat.git -flag two+flag five default: False- description: Use transformers 0.2. This must be selected manually and should- probably only be used on older GHCs around 7.0.x.- manual: True+ manual: False+ description: Use transformers 0.5 up until (but not including) 0.5.3. This will be selected by cabal picking the appropriate version. -flag three- default: False- manual: True- description: Use transformers 0.3. This should toggle on/off automatically.+flag five-three+ default: True+ manual: False+ description: Use transformers 0.5.3. This will be selected by cabal picking the appropriate version. flag mtl default: True manual: True- description: -f-mtl Disables support for mtl for transformers 0.2 and 0.3. That is an unsupported configuration, and results in missing instances for `ExceptT`, but keeps the package Haskell 98.+ description: -f-mtl Disables support for mtl for transformers 0.2 and 0.3. That is an unsupported configuration, and results in missing instances for `ExceptT`. +flag generic-deriving+ default: True+ manual: True+ description: -f-generic-deriving prevents generic-deriving from being built as a dependency.+ This disables certain aspects of generics for older versions of GHC. In particular,+ Generic(1) instances will not be backported prior to GHC 7.2, and generic operations+ over unlifted types will not be backported prior to GHC 8.0. This is an unsupported+ configuration.+ 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.5 && <0.7 + hs-source-dirs:+ src++ exposed-modules:+ Control.Monad.Trans.Instances+ other-modules: Paths_transformers_compat - if flag(three)- hs-source-dirs: 0.3- build-depends:- transformers >= 0.3 && < 0.4,- mtl >= 2.1 && < 2.2+ default-language:+ Haskell2010++ -- automatic flags+ if flag(five-three)+ build-depends: transformers >= 0.5.3 else- if flag(two)- hs-source-dirs: 0.2 0.3- build-depends:- transformers >= 0.2 && < 0.3,- mtl >= 2.0 && < 2.1- else- build-depends: transformers >= 0.4.1 && < 0.5+ build-depends: transformers < 0.5.3 - if !flag(mtl)- cpp-options: -DHASKELL98+ if flag(five)+ hs-source-dirs: 0.5+ build-depends: transformers >= 0.5 && < 0.5.3+ else+ build-depends: transformers >= 0.5.3 - if flag(two)+ -- other flags+ if impl(ghc) && flag(generic-deriving)+ hs-source-dirs: generics exposed-modules:- Control.Applicative.Backwards- Control.Applicative.Lift- Data.Functor.Reverse+ Data.Functor.Classes.Generic+ Data.Functor.Classes.Generic.Internal - if flag(two) || flag(three)+ if flag(mtl)+ cpp-options: -DMTL++ if !flag(mtl) && !flag(generic-deriving)+ cpp-options: -DHASKELL98++ if flag(five) exposed-modules:- Control.Monad.Trans.Except- Control.Monad.Signatures- Data.Functor.Classes- Data.Functor.Sum+ Control.Monad.Trans.Accum+ Control.Monad.Trans.Select