diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -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.* diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,3 @@ +- arguments: [--cpp-define=HLINT, --cpp-ansi] + +- ignore: {name: Avoid lambda} diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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" diff --git a/0.2/Control/Applicative/Backwards.hs b/0.2/Control/Applicative/Backwards.hs deleted file mode 100644 --- a/0.2/Control/Applicative/Backwards.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif --- | --- Module : Control.Applicative.Backwards --- Copyright : (c) Russell O'Connor 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Making functors with an 'Applicative' instance that performs actions --- in the reverse order. --- --- NB: This module is only included in @lens@ for backwards compatibility with --- @transformers@ versions before 3.0. -module Control.Applicative.Backwards where - -import Data.Functor.Classes - -import Prelude hiding (foldr, foldr1, foldl, foldl1) -import Control.Applicative -import Data.Foldable -import Data.Traversable - --- | The same functor, but with an 'Applicative' instance that performs --- actions in the reverse order. -newtype Backwards f a = Backwards { forwards :: f a } - -instance (Eq1 f) => Eq1 (Backwards f) where - liftEq eq (Backwards x) (Backwards y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (Backwards f) where - liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y - -instance (Read1 f) => Read1 (Backwards f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards - -instance (Show1 f) => Show1 (Backwards f) where - liftShowsPrec sp sl d (Backwards x) = - showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x - -instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 - --- | Derived instance. -instance (Functor f) => Functor (Backwards f) where - fmap f (Backwards a) = Backwards (fmap f a) - --- | 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) = foldr1 f t - foldl1 f (Backwards t) = foldl1 f t - --- | Derived instance. -instance (Traversable f) => Traversable (Backwards f) where - traverse f (Backwards t) = fmap Backwards (traverse f t) - sequenceA (Backwards t) = fmap Backwards (sequenceA t) diff --git a/0.2/Control/Applicative/Lift.hs b/0.2/Control/Applicative/Lift.hs deleted file mode 100644 --- a/0.2/Control/Applicative/Lift.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -#endif --- | --- Module : Control.Applicative.Lift --- Copyright : (c) Ross Paterson 2010 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Adding a new kind of pure computation to an applicative functor. --- --- NB: This module is only included in @lens@ for backwards compatibility with --- @transformers@ versions before 3.0. - -module Control.Applicative.Lift ( - -- * Lifting an applicative - Lift(..), - unLift, - mapLift, - -- * Collecting errors - Errors, - runErrors, - failure - ) where - -import Data.Functor.Classes - -import Control.Applicative -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Constant -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) - --- | Applicative functor formed by adding pure computations to a given --- applicative functor. -data Lift f a = Pure a | Other (f a) - -instance (Eq1 f) => Eq1 (Lift f) where - liftEq eq (Pure x1) (Pure x2) = eq x1 x2 - liftEq _ (Pure _) (Other _) = False - liftEq _ (Other _) (Pure _) = False - liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 - -instance (Ord1 f) => Ord1 (Lift f) where - liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 - liftCompare _ (Pure _) (Other _) = LT - liftCompare _ (Other _) (Pure _) = GT - liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 - -instance (Read1 f) => Read1 (Lift f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith rp "Pure" Pure `mappend` - readsUnaryWith (liftReadsPrec rp rl) "Other" Other - -instance (Show1 f) => Show1 (Lift f) where - liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x - liftShowsPrec sp sl d (Other y) = - showsUnaryWith (liftShowsPrec sp sl) "Other" d y - -instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 - -instance (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 - --- | Apply a transformation to the other computation. -mapLift :: (f a -> g a) -> Lift f a -> Lift g a -mapLift _ (Pure x) = Pure x -mapLift f (Other e) = Other (f e) - --- | An applicative functor that collects a monoid (e.g. lists) of errors. --- A sequence of computations fails if any of its components do, but --- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except", --- these computations continue after an error, collecting all the errors. --- --- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@ --- --- * @'pure' f '<*>' 'failure' e = 'failure' e@ --- --- * @'failure' e '<*>' 'pure' x = 'failure' e@ --- --- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@ --- -type Errors e = Lift (Constant e) - --- | Extractor for computations with accumulating errors. --- --- * @'runErrors' ('pure' x) = 'Right' x@ --- --- * @'runErrors' ('failure' e) = 'Left' e@ --- -runErrors :: Errors e a -> Either e a -runErrors (Other (Constant e)) = Left e -runErrors (Pure x) = Right x - --- | Report an error. -failure :: e -> Errors e a -failure e = Other (Constant e) diff --git a/0.2/Data/Functor/Reverse.hs b/0.2/Data/Functor/Reverse.hs deleted file mode 100644 --- a/0.2/Data/Functor/Reverse.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif --- | --- Module : Data.Functor.Reverse --- Copyright : (c) Russell O'Connor 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Making functors whose elements are notionally in the reverse order --- from the original functor. --- --- /NB:/ Note this module is only included in @lens@ for backwards --- compatibility with older @containers@ versions. - -module Data.Functor.Reverse where - -import Control.Applicative.Backwards -import Data.Functor.Classes - -import Prelude hiding (foldr, foldr1, foldl, foldl1) -import Control.Applicative -import Data.Foldable -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 } - -instance (Eq1 f) => Eq1 (Reverse f) where - liftEq eq (Reverse x) (Reverse y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (Reverse f) where - liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y - -instance (Read1 f) => Read1 (Reverse f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse - -instance (Show1 f) => Show1 (Reverse f) where - liftShowsPrec sp sl d (Reverse x) = - showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x - -instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 - --- | Derived instance. -instance (Functor f) => Functor (Reverse f) where - fmap f (Reverse a) = Reverse (fmap f a) - --- | 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) diff --git a/0.3/Control/Monad/Signatures.hs b/0.3/Control/Monad/Signatures.hs deleted file mode 100644 --- a/0.3/Control/Monad/Signatures.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Signatures --- Copyright : (c) Ross Paterson 2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Signatures for monad operations that require specialized lifting. --- Each signature has a uniformity property that the lifting should satisfy. ------------------------------------------------------------------------------ - -module Control.Monad.Signatures ( - CallCC, Catch, Listen, Pass - ) where - --- | Signature of the @callCC@ operation, --- introduced in "Control.Monad.Trans.Cont". --- Any lifting function @liftCallCC@ should satisfy --- --- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@ --- -type CallCC m a b = ((a -> m b) -> m a) -> m a - --- | Signature of the @catchE@ operation, --- introduced in "Control.Monad.Trans.Except". --- Any lifting function @liftCatch@ should satisfy --- --- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@ --- -type Catch e m a = m a -> (e -> m a) -> m a - --- | Signature of the @listen@ operation, --- introduced in "Control.Monad.Trans.Writer". --- Any lifting function @liftListen@ should satisfy --- --- * @'lift' . liftListen = liftListen . 'lift'@ --- -type Listen w m a = m a -> m (a, w) - --- | Signature of the @pass@ operation, --- introduced in "Control.Monad.Trans.Writer". --- Any lifting function @liftPass@ should satisfy --- --- * @'lift' . liftPass = liftPass . 'lift'@ --- -type Pass w m a = m (a, w -> w) -> m a diff --git a/0.3/Control/Monad/Trans/Except.hs b/0.3/Control/Monad/Trans/Except.hs deleted file mode 100644 --- a/0.3/Control/Monad/Trans/Except.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -#ifndef HASKELL98 -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Except --- Copyright : (C) 2013 Ross Paterson --- (C) 2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- This monad transformer extends a monad with the ability throw exceptions. --- --- A sequence of actions terminates normally, producing a value, --- only if none of the actions in the sequence throws an exception. --- If one throws an exception, the rest of the sequence is skipped and --- the composite action exits with that exception. --- --- If the value of the exception is not required, the variant in --- "Control.Monad.Trans.Maybe" may be used instead. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Except ( - -- * The Except monad - Except, - except, - runExcept, - mapExcept, - withExcept, - -- * The ExceptT monad transformer - ExceptT(..), - mapExceptT, - withExceptT, - -- * Exception operations - throwE, - catchE, - -- * 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 -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif - -#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) => Eq1 (ExceptT e m) where - liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y - -instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where - liftCompare comp (ExceptT x) (ExceptT y) = - liftCompare (liftCompare comp) x y - -instance (Read e, Read1 m) => Read1 (ExceptT e m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show e, Show1 m) => Show1 (ExceptT e m) where - liftShowsPrec sp sl d (ExceptT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1 -instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1 -instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where - readsPrec = readsPrec1 -instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where - showsPrec = showsPrec1 - --- | Map the unwrapped computation using the given function. --- --- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ -mapExceptT :: (m (Either e a) -> n (Either e' b)) - -> ExceptT e m a - -> ExceptT e' n b -mapExceptT f m = ExceptT $ f (runExceptT m) - --- | 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 = ExceptT $ return (Left mempty) - ExceptT mx <|> ExceptT my = ExceptT $ do - ex <- mx - case ex of - Left e -> liftM (either (Left . mappend e) Right) my - Right x -> return (Right x) - -instance (Monad m) => Monad (ExceptT e m) where - return a = ExceptT $ return (Right a) - 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 (runExceptT . f . either (const bomb) id)) - where bomb = error "mfix (ExceptT): inner computation returned Left value" - -instance MonadTrans (ExceptT e) where - lift = ExceptT . liftM Right - -instance (MonadIO m) => MonadIO (ExceptT e m) where - liftIO = lift . liftIO - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (ExceptT e m) where - mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b -#endif - --- | Signal an exception value @e@. --- --- * @'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 diff --git a/0.3/Data/Functor/Classes.hs b/0.3/Data/Functor/Classes.hs deleted file mode 100644 --- a/0.3/Data/Functor/Classes.hs +++ /dev/null @@ -1,839 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(a,b,c) 1 -#endif - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -# endif -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Classes --- Copyright : (c) Ross Paterson 2013, Edward Kmett 2014 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to --- unary and binary type constructors. --- --- These classes are needed to express the constraints on arguments of --- transformers in portable Haskell. Thus for a new transformer @T@, --- one might write instances like --- --- > instance (Eq1 f) => Eq1 (T f) where ... --- > instance (Ord1 f) => Ord1 (T f) where ... --- > instance (Read1 f) => Read1 (T f) where ... --- > instance (Show1 f) => Show1 (T f) where ... --- --- If these instances can be defined, defining instances of the base --- classes is mechanical: --- --- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 --- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 --- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1 --- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 --- ------------------------------------------------------------------------------ - -module Data.Functor.Classes ( - -- * Liftings of Prelude classes - -- ** For unary constructors - Eq1(..), eq1, - Ord1(..), compare1, - Read1(..), readsPrec1, - Show1(..), showsPrec1, - -- ** For binary constructors - Eq2(..), eq2, - Ord2(..), compare2, - Read2(..), readsPrec2, - Show2(..), showsPrec2, - -- * Helper functions - -- $example - readsData, - readsUnaryWith, - readsBinaryWith, - showsUnaryWith, - showsBinaryWith, - -- ** Obsolete helpers - readsUnary, - readsUnary1, - readsBinary1, - showsUnary, - showsUnary1, - showsBinary1, - ) where - -import Control.Applicative (Const(Const)) -import Data.Functor.Identity (Identity(Identity)) -import Data.Monoid (mappend) -import Text.Show (showListWith) - -import Control.Monad.Trans.Error -import Control.Monad.Trans.Identity -import Control.Monad.Trans.List -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Data.Functor.Compose -import Data.Functor.Constant -import Data.Functor.Product - -#if MIN_VERSION_transformers(0,3,0) -import Control.Applicative.Lift -import Control.Applicative.Backwards -import Data.Functor.Reverse -#endif - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -# endif -#endif - --- | Lifting of the 'Eq' class to unary type constructors. -class Eq1 f where - -- | Lift an equality test through the type constructor. - -- - -- The function will usually be applied to an equality function, - -- but the more general type ensures that the implementation uses - -- it to compare elements of the first container with elements of - -- the second. - liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool - --- | Lift the standard @('==')@ function through the type constructor. -eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool -eq1 = liftEq (==) - --- | Lifting of the 'Ord' class to unary type constructors. -class (Eq1 f) => Ord1 f where - -- | Lift a 'compare' function through the type constructor. - -- - -- The function will usually be applied to a comparison function, - -- but the more general type ensures that the implementation uses - -- it to compare elements of the first container with elements of - -- the second. - liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering - --- | Lift the standard 'compare' function through the type constructor. -compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering -compare1 = liftCompare compare - --- | Lifting of the 'Read' class to unary type constructors. -class Read1 f where - -- | 'readsPrec' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument type. - liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) - - -- | 'readList' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument type. - -- The default implementation using standard list syntax is correct - -- for most types. - liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] - liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) - --- | Read a list (using square brackets and commas), given a function --- for reading elements. -readListWith :: ReadS a -> ReadS [a] -readListWith rp = - readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) - where - readl s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] - readl' s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] - --- | Lift the standard 'readsPrec' and 'readList' functions through the --- type constructor. -readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) -readsPrec1 = liftReadsPrec readsPrec readList - --- | Lifting of the 'Show' class to unary type constructors. -class Show1 f where - -- | 'showsPrec' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument type. - liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - Int -> f a -> ShowS - - -- | 'showList' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument type. - -- The default implementation using standard list syntax is correct - -- for most types. - liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - [f a] -> ShowS - liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) - --- | Lift the standard 'showsPrec' and 'showList' functions through the --- type constructor. -showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS -showsPrec1 = liftShowsPrec showsPrec showList - --- | Lifting of the 'Eq' class to binary type constructors. -class Eq2 f where - -- | Lift equality tests through the type constructor. - -- - -- The function will usually be applied to equality functions, - -- but the more general type ensures that the implementation uses - -- them to compare elements of the first container with elements of - -- the second. - liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool - --- | Lift the standard @('==')@ function through the type constructor. -eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool -eq2 = liftEq2 (==) (==) - --- | Lifting of the 'Ord' class to binary type constructors. -class (Eq2 f) => Ord2 f where - -- | Lift 'compare' functions through the type constructor. - -- - -- The function will usually be applied to comparison functions, - -- but the more general type ensures that the implementation uses - -- them to compare elements of the first container with elements of - -- the second. - liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> - f a c -> f b d -> Ordering - --- | Lift the standard 'compare' function through the type constructor. -compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering -compare2 = liftCompare2 compare compare - --- | Lifting of the 'Read' class to binary type constructors. -class Read2 f where - -- | 'readsPrec' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument types. - liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> - (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) - - -- | 'readList' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument types. - -- The default implementation using standard list syntax is correct - -- for most types. - liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> - (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] - liftReadList2 rp1 rl1 rp2 rl2 = - readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) - --- | Lift the standard 'readsPrec' function through the type constructor. -readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) -readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList - --- | Lifting of the 'Show' class to binary type constructors. -class Show2 f where - -- | 'showsPrec' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument types. - liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS - - -- | 'showList' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument types. - -- The default implementation using standard list syntax is correct - -- for most types. - liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS - liftShowList2 sp1 sl1 sp2 sl2 = - showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) - --- | Lift the standard 'showsPrec' function through the type constructor. -showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS -showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList - --- Instances for Prelude type constructors - -instance Eq1 Maybe where - liftEq _ Nothing Nothing = True - liftEq _ Nothing (Just _) = False - liftEq _ (Just _) Nothing = False - liftEq eq (Just x) (Just y) = eq x y - -instance Ord1 Maybe where - liftCompare _ Nothing Nothing = EQ - liftCompare _ Nothing (Just _) = LT - liftCompare _ (Just _) Nothing = GT - liftCompare comp (Just x) (Just y) = comp x y - -instance Read1 Maybe where - liftReadsPrec rp _ d = - readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) - `mappend` - readsData (readsUnaryWith rp "Just" Just) d - -instance Show1 Maybe where - liftShowsPrec _ _ _ Nothing = showString "Nothing" - liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x - -instance Eq1 [] where - liftEq _ [] [] = True - liftEq _ [] (_:_) = False - liftEq _ (_:_) [] = False - liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys - -instance Ord1 [] where - liftCompare _ [] [] = EQ - liftCompare _ [] (_:_) = LT - liftCompare _ (_:_) [] = GT - liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys - -instance Read1 [] where - liftReadsPrec _ rl _ = rl - -instance Show1 [] where - liftShowsPrec _ sl _ = sl - -instance Eq2 (,) where - liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 - -instance Ord2 (,) where - liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = - comp1 x1 x2 `mappend` comp2 y1 y2 - -instance Read2 (,) where - liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> - [((x,y), w) | ("(",s) <- lex r, - (x,t) <- rp1 0 s, - (",",u) <- lex t, - (y,v) <- rp2 0 u, - (")",w) <- lex v] - -instance Show2 (,) where - liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = - showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' - -instance (Eq a) => Eq1 ((,) a) where - liftEq = liftEq2 (==) - -instance (Ord a) => Ord1 ((,) a) where - liftCompare = liftCompare2 compare - -instance (Read a) => Read1 ((,) a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a) => Show1 ((,) a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Eq2 Either where - liftEq2 e1 _ (Left x) (Left y) = e1 x y - liftEq2 _ _ (Left _) (Right _) = False - liftEq2 _ _ (Right _) (Left _) = False - liftEq2 _ e2 (Right x) (Right y) = e2 x y - -instance Ord2 Either where - liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y - liftCompare2 _ _ (Left _) (Right _) = LT - liftCompare2 _ _ (Right _) (Left _) = GT - liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y - -instance Read2 Either where - liftReadsPrec2 rp1 _ rp2 _ = readsData $ - readsUnaryWith rp1 "Left" Left `mappend` - readsUnaryWith rp2 "Right" Right - -instance Show2 Either where - liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x - liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x - -instance (Eq a) => Eq1 (Either a) where - liftEq = liftEq2 (==) - -instance (Ord a) => Ord1 (Either a) where - liftCompare = liftCompare2 compare - -instance (Read a) => Read1 (Either a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a) => Show1 (Either a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - --- Instances for other functors defined in the base package - -instance Eq1 Identity where - liftEq eq (Identity x) (Identity y) = eq x y - -instance Ord1 Identity where - liftCompare comp (Identity x) (Identity y) = comp x y - -instance Read1 Identity where - liftReadsPrec rp _ = readsData $ - readsUnaryWith rp "Identity" Identity - -instance Show1 Identity where - liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x - -instance Eq2 Const where - liftEq2 eq _ (Const x) (Const y) = eq x y - -instance Ord2 Const where - liftCompare2 comp _ (Const x) (Const y) = comp x y - -instance Read2 Const where - liftReadsPrec2 rp _ _ _ = readsData $ - readsUnaryWith rp "Const" Const - -instance Show2 Const where - liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x - -instance (Eq a) => Eq1 (Const a) where - liftEq = liftEq2 (==) -instance (Ord a) => Ord1 (Const a) where - liftCompare = liftCompare2 compare -instance (Read a) => Read1 (Const a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList -instance (Show a) => Show1 (Const a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - --- Building blocks - --- | @'readsData' p d@ is a parser for datatypes where each alternative --- begins with a data constructor. It parses the constructor and --- passes it to @p@. Parsers for various constructors can be constructed --- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with --- @mappend@ from the @Monoid@ class. -readsData :: (String -> ReadS a) -> Int -> ReadS a -readsData reader d = - readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] - --- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor --- and then parses its argument using @rp@. -readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t -readsUnaryWith rp name cons kw s = - [(cons x,t) | kw == name, (x,t) <- rp 11 s] - --- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary --- data constructor and then parses its arguments using @rp1@ and @rp2@ --- respectively. -readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> - String -> (a -> b -> t) -> String -> ReadS t -readsBinaryWith rp1 rp2 name cons kw s = - [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] - --- | @'showsUnaryWith' sp n d x@ produces the string representation of a --- unary data constructor with name @n@ and argument @x@, in precedence --- context @d@. -showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS -showsUnaryWith sp name d x = showParen (d > 10) $ - showString name . showChar ' ' . sp 11 x - --- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string --- representation of a binary data constructor with name @n@ and arguments --- @x@ and @y@, in precedence context @d@. -showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> - String -> Int -> a -> b -> ShowS -showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ - showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y - --- Obsolete building blocks - --- | @'readsUnary' n c n'@ matches the name of a unary data constructor --- and then parses its argument using 'readsPrec'. -{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} -readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t -readsUnary name cons kw s = - [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] - --- | @'readsUnary1' n c n'@ matches the name of a unary data constructor --- and then parses its argument using 'readsPrec1'. -{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} -readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t -readsUnary1 name cons kw s = - [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] - --- | @'readsBinary1' n c n'@ matches the name of a binary data constructor --- and then parses its arguments using 'readsPrec1'. -{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} -readsBinary1 :: (Read1 f, Read1 g, Read a) => - String -> (f a -> g a -> t) -> String -> ReadS t -readsBinary1 name cons kw s = - [(cons x y,u) | kw == name, - (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] - --- | @'showsUnary' n d x@ produces the string representation of a unary data --- constructor with name @n@ and argument @x@, in precedence context @d@. -{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} -showsUnary :: (Show a) => String -> Int -> a -> ShowS -showsUnary name d x = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec 11 x - --- | @'showsUnary1' n d x@ produces the string representation of a unary data --- constructor with name @n@ and argument @x@, in precedence context @d@. -{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} -showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS -showsUnary1 name d x = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec1 11 x - --- | @'showsBinary1' n d x y@ produces the string representation of a binary --- data constructor with name @n@ and arguments @x@ and @y@, in precedence --- context @d@. -{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} -showsBinary1 :: (Show1 f, Show1 g, Show a) => - String -> Int -> f a -> g a -> ShowS -showsBinary1 name d x y = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec1 11 x . - showChar ' ' . showsPrec1 11 y - - -instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where - liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y - -instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where - liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y - -instance (Read e, Read1 m) => Read1 (ErrorT e m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show e, Show1 m) => Show1 (ErrorT e m) where - liftShowsPrec sp sl d (ErrorT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1 -instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1 -instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where - readsPrec = readsPrec1 -instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where - showsPrec = showsPrec1 - -instance (Eq1 f) => Eq1 (IdentityT f) where - liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (IdentityT f) where - liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y - -instance (Read1 f) => Read1 (IdentityT f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT - -instance (Show1 f) => Show1 (IdentityT f) where - liftShowsPrec sp sl d (IdentityT m) = - showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m - -instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1 -instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1 - -instance (Eq1 m) => Eq1 (ListT m) where - liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y - -instance (Ord1 m) => Ord1 (ListT m) where - liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y - -instance (Read1 m) => Read1 (ListT m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 m) => Show1 (ListT m) where - liftShowsPrec sp sl d (ListT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1 -instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1 -instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1 -instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 - -instance (Eq1 m) => Eq1 (MaybeT m) where - liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y - -instance (Ord1 m) => Ord1 (MaybeT m) where - liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y - -instance (Read1 m) => Read1 (MaybeT m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 m) => Show1 (MaybeT m) where - liftShowsPrec sp sl d (MaybeT m) = - showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1 -instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1 -instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1 -instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 - -instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where - liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) = - liftEq (liftEq2 eq (==)) m1 m2 - -instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where - liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) = - liftCompare (liftCompare2 comp compare) m1 m2 - -instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT - where - rp' = liftReadsPrec2 rp rl readsPrec readList - rl' = liftReadList2 rp rl readsPrec readList - -instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where - liftShowsPrec sp sl d (Lazy.WriterT m) = - showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m - where - sp' = liftShowsPrec2 sp sl showsPrec showList - sl' = liftShowList2 sp sl showsPrec showList - -instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where - (==) = eq1 -instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where - compare = compare1 -instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where - readsPrec = readsPrec1 -instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where - showsPrec = showsPrec1 - -instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where - liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) = - liftEq (liftEq2 eq (==)) m1 m2 - -instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where - liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) = - liftCompare (liftCompare2 comp compare) m1 m2 - -instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT - where - rp' = liftReadsPrec2 rp rl readsPrec readList - rl' = liftReadList2 rp rl readsPrec readList - -instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where - liftShowsPrec sp sl d (Strict.WriterT m) = - showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m - where - sp' = liftShowsPrec2 sp sl showsPrec showList - sl' = liftShowList2 sp sl showsPrec showList - -instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where - (==) = eq1 -instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where - compare = compare1 -instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where - readsPrec = readsPrec1 -instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where - showsPrec = showsPrec1 - -instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where - liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y - -instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where - liftCompare comp (Compose x) (Compose y) = - liftCompare (liftCompare comp) x y - -instance (Read1 f, Read1 g) => Read1 (Compose f g) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 f, Show1 g) => Show1 (Compose f g) where - liftShowsPrec sp sl d (Compose x) = - showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where - (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where - showsPrec = showsPrec1 - -instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where - liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 - -instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where - liftCompare comp (Pair x1 y1) (Pair x2 y2) = - liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 - -instance (Read1 f, Read1 g) => Read1 (Product f g) where - liftReadsPrec rp rl = readsData $ - readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair - -instance (Show1 f, Show1 g) => Show1 (Product f g) where - liftShowsPrec sp sl d (Pair x y) = - showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) - where (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where - showsPrec = showsPrec1 - -instance Eq2 Constant where - liftEq2 eq _ (Constant x) (Constant y) = eq x y -instance Ord2 Constant where - liftCompare2 comp _ (Constant x) (Constant y) = comp x y -instance Read2 Constant where - liftReadsPrec2 rp _ _ _ = readsData $ - readsUnaryWith rp "Constant" Constant -instance Show2 Constant where - liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x - -instance (Eq a) => Eq1 (Constant a) where - liftEq = liftEq2 (==) -instance (Ord a) => Ord1 (Constant a) where - liftCompare = liftCompare2 compare -instance (Read a) => Read1 (Constant a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList -instance (Show a) => Show1 (Constant a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Eq a => Eq (Constant a b) where - Constant a == Constant b = a == b -instance Ord a => Ord (Constant a b) where - compare (Constant a) (Constant b) = compare a b -instance (Read a) => Read (Constant a b) where - readsPrec = readsData $ - readsUnaryWith readsPrec "Constant" Constant -instance (Show a) => Show (Constant a b) where - showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x - -instance Show a => Show (Identity a) where - showsPrec d (Identity a) = showParen (d > 10) $ - showString "Identity " . showsPrec 11 a -instance Read a => Read (Identity a) where - readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s]) -instance Eq a => Eq (Identity a) where - Identity a == Identity b = a == b -instance Ord a => Ord (Identity a) where - compare (Identity a) (Identity b) = compare a b - -#if MIN_VERSION_transformers(0,3,0) -instance (Eq1 f) => Eq1 (Lift f) where - liftEq eq (Pure x1) (Pure x2) = eq x1 x2 - liftEq _ (Pure _) (Other _) = False - liftEq _ (Other _) (Pure _) = False - liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 - -instance (Ord1 f) => Ord1 (Lift f) where - liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 - liftCompare _ (Pure _) (Other _) = LT - liftCompare _ (Other _) (Pure _) = GT - liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 - -instance (Read1 f) => Read1 (Lift f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith rp "Pure" Pure `mappend` - readsUnaryWith (liftReadsPrec rp rl) "Other" Other - -instance (Show1 f) => Show1 (Lift f) where - liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x - liftShowsPrec sp sl d (Other y) = - showsUnaryWith (liftShowsPrec sp sl) "Other" d y - -instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 - -instance (Eq1 f) => Eq1 (Backwards f) where - liftEq eq (Backwards x) (Backwards y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (Backwards f) where - liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y - -instance (Read1 f) => Read1 (Backwards f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards - -instance (Show1 f) => Show1 (Backwards f) where - liftShowsPrec sp sl d (Backwards x) = - showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x - -instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 - -instance (Eq1 f) => Eq1 (Reverse f) where - liftEq eq (Reverse x) (Reverse y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (Reverse f) where - liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y - -instance (Read1 f) => Read1 (Reverse f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse - -instance (Show1 f) => Show1 (Reverse f) where - liftShowsPrec sp sl d (Reverse x) = - showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x - -instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 -#endif - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Eq1 -deriving instance Typeable Eq2 -deriving instance Typeable Ord1 -deriving instance Typeable Ord2 -deriving instance Typeable Read1 -deriving instance Typeable Read2 -deriving instance Typeable Show1 -deriving instance Typeable Show2 -# endif -#endif - -{- $example -These functions can be used to assemble 'Read' and 'Show' instances for -new algebraic types. For example, given the definition - -> data T f a = Zero a | One (f a) | Two a (f a) - -a standard 'Read1' instance may be defined as - -> instance (Read1 f) => Read1 (T f) where -> liftReadsPrec rp rl = readsData $ -> readsUnaryWith rp "Zero" Zero `mappend` -> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` -> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two - -and the corresponding 'Show1' instance as - -> instance (Show1 f) => Show1 (T f) where -> liftShowsPrec sp _ d (Zero x) = -> showsUnaryWith sp "Zero" d x -> liftShowsPrec sp sl d (One x) = -> showsUnaryWith (liftShowsPrec sp sl) "One" d x -> liftShowsPrec sp sl d (Two x y) = -> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y - --} diff --git a/0.3/Data/Functor/Sum.hs b/0.3/Data/Functor/Sum.hs deleted file mode 100644 --- a/0.3/Data/Functor/Sum.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -# endif -#endif --- | --- Module : Data.Functor.Sum --- Copyright : (c) Ross Paterson 2014 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Sums, lifted to functors. - -module Data.Functor.Sum ( - Sum(..), - ) where - -import Control.Applicative -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Classes -import Data.Monoid (mappend) -import Data.Traversable (Traversable(traverse)) - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -# endif -# if __GLASGOW_HASKELL__ >= 708 -import Data.Data -# endif -#endif - --- | Lifted sum of functors. -data Sum f g a = InL (f a) | InR (g a) - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 -deriving instance Generic (Sum f g a) - -instance Generic1 (Sum f g) where - type Rep1 (Sum f g) = - D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f)) - :+: C1 MCInR (S1 NoSelector (Rec1 g))) - from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f)))) - from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g)))) - to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f) - to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) - -data MDSum -data MCInL -data MCInR - -instance Datatype MDSum where - datatypeName _ = "Sum" - moduleName _ = "Data.Functor.Sum" - -instance Constructor MCInL where - conName _ = "InL" - -instance Constructor MCInR where - conName _ = "InR" -# endif - -# if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Sum -deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) - => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) -# endif -#endif - -instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where - liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 - liftEq _ (InL _) (InR _) = False - liftEq _ (InR _) (InL _) = False - liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 - -instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where - liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 - liftCompare _ (InL _) (InR _) = LT - liftCompare _ (InR _) (InL _) = GT - liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 - -instance (Read1 f, Read1 g) => Read1 (Sum f g) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` - readsUnaryWith (liftReadsPrec rp rl) "InR" InR - -instance (Show1 f, Show1 g) => Show1 (Sum f g) where - liftShowsPrec sp sl d (InL x) = - showsUnaryWith (liftShowsPrec sp sl) "InL" d x - liftShowsPrec sp sl d (InR y) = - showsUnaryWith (liftShowsPrec sp sl) "InR" d y - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where - (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where - showsPrec = showsPrec1 - -instance (Functor f, Functor g) => Functor (Sum f g) where - fmap f (InL x) = InL (fmap f x) - fmap f (InR y) = InR (fmap f y) - -instance (Foldable f, Foldable g) => Foldable (Sum f g) where - foldMap f (InL x) = foldMap f x - foldMap f (InR y) = foldMap f y - -instance (Traversable f, Traversable g) => Traversable (Sum f g) where - traverse f (InL x) = InL <$> traverse f x - traverse f (InR y) = InR <$> traverse f y diff --git a/0.5/Control/Monad/Trans/Accum.hs b/0.5/Control/Monad/Trans/Accum.hs new file mode 100644 --- /dev/null +++ b/0.5/Control/Monad/Trans/Accum.hs @@ -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 #-} diff --git a/0.5/Control/Monad/Trans/Select.hs b/0.5/Control/Monad/Trans/Select.hs new file mode 100644 --- /dev/null +++ b/0.5/Control/Monad/Trans/Select.hs @@ -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. +-- +-- +-- * Jules Hedges. "Monad transformers for backtracking search". +-- In /Proceedings of MSFP 2014/. +----------------------------------------------------------------------------- + +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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 ----- diff --git a/HLint.hs b/HLint.hs deleted file mode 100644 --- a/HLint.hs +++ /dev/null @@ -1,1 +0,0 @@ -ignore "Warning: Avoid lambda" diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,11 +1,19 @@ transformers-compat =================== -[![Hackage](https://img.shields.io/hackage/v/transformers-compat.svg)](https://hackage.haskell.org/package/transformers-compat) [![Build Status](https://secure.travis-ci.org/ekmett/transformers-compat.png?branch=master)](http://travis-ci.org/ekmett/transformers-compat) +[![Hackage](https://img.shields.io/hackage/v/transformers-compat.svg)](https://hackage.haskell.org/package/transformers-compat) [![Build Status](https://github.com/ekmett/transformers-compat/workflows/Haskell-CI/badge.svg)](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 ------------------- diff --git a/generics/Data/Functor/Classes/Generic.hs b/generics/Data/Functor/Classes/Generic.hs new file mode 100644 --- /dev/null +++ b/generics/Data/Functor/Classes/Generic.hs @@ -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' +@ +-} diff --git a/generics/Data/Functor/Classes/Generic/Internal.hs b/generics/Data/Functor/Classes/Generic/Internal.hs new file mode 100644 --- /dev/null +++ b/generics/Data/Functor/Classes/Generic/Internal.hs @@ -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 diff --git a/src/Control/Monad/Trans/Instances.hs b/src/Control/Monad/Trans/Instances.hs --- a/src/Control/Monad/Trans/Instances.hs +++ b/src/Control/Monad/Trans/Instances.hs @@ -1,29 +1,20 @@ {-# 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 #-} - -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE Trustworthy #-} -# endif - -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif - -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE DataKinds #-} -# endif #endif -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Instances @@ -48,17 +39,18 @@ 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.Class (MonadTrans) +import Control.Monad.Trans.Accum (AccumT(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Cont (ContT(..)) -import Control.Monad.Trans.Error (ErrorT(..)) -import Control.Monad.Trans.Except () +import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Identity (IdentityT(..)) -import Control.Monad.Trans.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..)) import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) import Control.Monad.Trans.Reader (ReaderT(..)) +import 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(..)) @@ -69,318 +61,141 @@ import Data.Functor.Identity (Identity(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Reverse (Reverse(..)) -import Data.Functor.Sum () +import Data.Functor.Sum (Sum(..)) import Control.Applicative -import Control.Monad (MonadPlus(..)) +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_base(4,4,0) -import Control.Monad.Zip (MonadZip(..)) +#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,8,0) -import Data.Bifunctor (Bifunctor(..)) +#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 - -# if __GLASGOW_HASKELL__ >= 702 import GHC.Generics -# endif #endif -#if !(MIN_VERSION_transformers(0,3,0)) --- Foldable/Traversable instances -instance (Foldable f) => Foldable (ErrorT e f) where - foldMap f (ErrorT a) = foldMap (either (const mempty) f) a - -instance (Traversable f) => Traversable (ErrorT e f) where - traverse f (ErrorT a) = - ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a - -instance (Foldable f) => Foldable (IdentityT f) where - foldMap f (IdentityT a) = foldMap f a - -instance (Traversable f) => Traversable (IdentityT f) where - traverse f (IdentityT a) = IdentityT <$> traverse f a - -instance (Foldable f) => Foldable (ListT f) where - foldMap f (ListT a) = foldMap (foldMap f) a - -instance (Traversable f) => Traversable (ListT f) where - traverse f (ListT a) = ListT <$> traverse (traverse f) a - -instance (Foldable f) => Foldable (MaybeT f) where - foldMap f (MaybeT a) = foldMap (foldMap f) a - -instance (Traversable f) => Traversable (MaybeT f) where - traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a - -instance (Foldable f) => Foldable (Lazy.WriterT w f) where - foldMap f = foldMap (f . fst) . Lazy.runWriterT - -instance (Traversable f) => Traversable (Lazy.WriterT w f) where - traverse f = fmap Lazy.WriterT . traverse f' . Lazy.runWriterT where - f' (a, b) = fmap (\ c -> (c, b)) (f a) - -instance (Foldable f) => Foldable (Strict.WriterT w f) where - foldMap f = foldMap (f . fst) . Strict.runWriterT - -instance (Traversable f) => Traversable (Strict.WriterT w f) where - traverse f = fmap Strict.WriterT . traverse f' . Strict.runWriterT where - f' (a, b) = fmap (\ c -> (c, b)) (f a) - --- MonadFix instances for IdentityT and MaybeT -instance (MonadFix m) => MonadFix (IdentityT m) where - mfix f = IdentityT (mfix (runIdentityT . f)) - -instance (MonadFix m) => MonadFix (MaybeT m) where - mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb)) - where bomb = error "mfix (MaybeT): inner computation returned Nothing" - -# if !(MIN_VERSION_base(4,9,0)) --- Monad instances for Product -instance (Monad f, Monad g) => Monad (Product f g) where - return x = Pair (return x) (return x) - Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) - where - fstP (Pair a _) = a - sndP (Pair _ b) = b +#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 (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where - mzero = Pair mzero mzero - Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) +instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where + fail msg = Reverse (Fail.fail msg) + {-# INLINE fail #-} -instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where - mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) - where - fstP (Pair a _) = a - sndP (Pair _ b) = b -# endif +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,4,0)) --- Alternative IO instance -# if !(MIN_VERSION_base(4,9,0)) --- The version bounds of transformers prior to 0.4.0.0 should prevent this --- instance from being compiled on base-4.8.0.0 and later, but we'll put --- a check here just to be safe. -instance Alternative IO where - empty = mzero - (<|>) = mplus -# endif -#endif +#if !(MIN_VERSION_transformers(0,5,4)) +# if MIN_VERSION_base(4,10,0) +instance Bifoldable Constant where + bifoldMap f _ (Constant a) = f a + {-# INLINE bifoldMap #-} -#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,4,3)) --- transformers-0.4-specific Eq1, Ord1, Read1, and Show1 instances for Const -instance (Eq a) => Eq1 (Const a) where - eq1 (Const x) (Const y) = x == y -instance (Ord a) => Ord1 (Const a) where - compare1 (Const x) (Const y) = compare x y -instance (Read a) => Read1 (Const a) where - readsPrec1 = readsData $ readsUnary "Const" Const -instance (Show a) => Show1 (Const a) where - showsPrec1 d (Const x) = showsUnary "Const" d x +instance Bitraversable Constant where + bitraverse f _ (Constant a) = Constant <$> f a + {-# INLINE bitraverse #-} +# endif #endif -#if !(MIN_VERSION_transformers(0,5,0)) --- Monoid Constant instance -instance (Monoid a) => Monoid (Constant a b) where - mempty = Constant mempty - Constant x `mappend` Constant y = Constant (x `mappend` y) - --- MonadZip instances -# if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (IdentityT m) where - mzipWith f (IdentityT a) (IdentityT b) = IdentityT (mzipWith f a b) - -instance (MonadZip m) => MonadZip (ListT m) where - mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b - -instance (MonadZip m) => MonadZip (MaybeT m) where - mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b - -instance (MonadZip m) => MonadZip (ReaderT r m) where - mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a -> - mzipWith f (m a) (n a) - -instance (Monoid w, MonadZip m) => MonadZip (Lazy.WriterT w m) where - mzipWith f (Lazy.WriterT x) (Lazy.WriterT y) = Lazy.WriterT $ - mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y - -instance (Monoid w, MonadZip m) => MonadZip (Strict.WriterT w m) where - mzipWith f (Strict.WriterT x) (Strict.WriterT y) = Strict.WriterT $ - mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y - -# if !(MIN_VERSION_base(4,8,0)) -instance MonadZip Identity where - mzipWith f (Identity x) (Identity y) = Identity (f x y) - munzip (Identity (a, b)) = (Identity a, Identity b) -# endif - -# if !(MIN_VERSION_base(4,9,0)) -instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where - mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) -# endif -# endif +#if !(MIN_VERSION_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_base(4,8,0) --- Bifunctor Constant instance -instance Bifunctor Constant where - first f (Constant x) = Constant (f x) - second _ (Constant x) = Constant x -# else --- Monoid Identity instance -instance (Monoid a) => Monoid (Identity a) where - mempty = Identity mempty - mappend (Identity x) (Identity y) = Identity (mappend x y) +# 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 - -# ifndef HASKELL98 --- Typeable instances -# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -deriving instance Typeable Backwards -deriving instance Typeable Constant -deriving instance Typeable ContT -deriving instance Typeable ErrorT -deriving instance Typeable IdentityT -deriving instance Typeable Lift -deriving instance Typeable ListT -deriving instance Typeable MaybeT -deriving instance Typeable MonadTrans -deriving instance Typeable Lazy.RWST -deriving instance Typeable Strict.RWST -deriving instance Typeable ReaderT -deriving instance Typeable Reverse -deriving instance Typeable Lazy.StateT -deriving instance Typeable Strict.StateT - -# if !(MIN_VERSION_base(4,9,0)) -deriving instance Typeable Compose -deriving instance Typeable MonadIO -deriving instance Typeable Product -# endif -# endif - --- Identity instances -# if !(MIN_VERSION_base(4,8,0)) -deriving instance Typeable1 Identity -deriving instance Data a => Data (Identity a) - -# if __GLASGOW_HASKELL__ >= 702 -instance Generic (Identity a) where - type Rep (Identity a) = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity (Rec0 a))) - from (Identity x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Identity x - -instance Generic1 Identity where - type Rep1 Identity = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity Par1)) - from1 (Identity x) = M1 (M1 (M1 (Par1 x))) - to1 (M1 (M1 (M1 x))) = Identity (unPar1 x) - -data MDIdentity -data MCIdentity -data MSIdentity - -instance Datatype MDIdentity where - datatypeName _ = "Identity" - moduleName _ = "Data.Functor.Identity" -# if __GLASGOW_HASKELL__ >= 708 - isNewtype _ = True -# endif - -instance Constructor MCIdentity where - conName _ = "Identity" - conIsRecord _ = True +#endif -instance Selector MSIdentity where - selName _ = "runIdentity" -# 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) -# if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable 'Identity -# endif -# endif +deriving instance Generic (Constant a b) +deriving instance Generic1 (Constant a) -# if !(MIN_VERSION_base(4,9,0)) -# if __GLASGOW_HASKELL__ >= 702 --- Generic(1) instances for Compose -instance Generic (Compose f g a) where - type Rep (Compose f g a) = - D1 MDCompose - (C1 MCCompose - (S1 MSCompose (Rec0 (f (g a))))) - from (Compose x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Compose x +deriving instance Generic (ContT r m a) -instance Functor f => Generic1 (Compose f g) where - type Rep1 (Compose f g) = - D1 MDCompose - (C1 MCCompose - (S1 MSCompose (f :.: Rec1 g))) - from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x)))) - to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x)) +deriving instance Generic (IdentityT f a) +deriving instance Generic1 (IdentityT f) -data MDCompose -data MCCompose -data MSCompose +deriving instance Generic (MaybeT m a) +deriving instance Functor m => Generic1 (MaybeT m) -instance Datatype MDCompose where - datatypeName _ = "Compose" - moduleName _ = "Data.Functor.Compose" -# if __GLASGOW_HASKELL__ >= 708 - isNewtype _ = True -# endif +deriving instance Generic (Lazy.RWST r w s m a) +deriving instance Generic (Strict.RWST r w s m a) -instance Constructor MCCompose where - conName _ = "Compose" - conIsRecord _ = True +deriving instance Generic (ReaderT r m a) +deriving instance Generic1 (ReaderT r m) -instance Selector MSCompose where - selName _ = "getCompose" +deriving instance Generic (Lazy.StateT s m a) +deriving instance Generic (Strict.StateT s m a) --- Generic(1) instances for Product -instance Generic (Product f g a) where - type Rep (Product f g a) = - D1 MDProduct - (C1 MCPair - (S1 NoSelector (Rec0 (f a)) :*: S1 NoSelector (Rec0 (g a)))) - from (Pair f g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g))) - to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = Pair f g +deriving instance Generic (Lazy.WriterT w m a) +deriving instance Generic (Strict.WriterT w m a) -instance Generic1 (Product f g) where - type Rep1 (Product f g) = - D1 MDProduct - (C1 MCPair - (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g))) - from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) - to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g) +deriving instance Generic (Backwards f a) +deriving instance Generic1 (Backwards f) -data MDProduct -data MCPair +deriving instance Generic (Lift f a) +deriving instance Generic1 (Lift f) -instance Datatype MDProduct where - datatypeName _ = "Product" - moduleName _ = "Data.Functor.Product" +deriving instance Generic (Reverse f a) +deriving instance Generic1 (Reverse f) -instance Constructor MCPair where - conName _ = "Pair" -# endif +deriving instance Generic (ExceptT e m a) +deriving instance Functor m => Generic1 (ExceptT e m) -# if __GLASGOW_HASKELL__ >= 708 --- Data instances for Compose and Product -deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) - => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) -deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) - => Data (Product (f :: * -> *) (g :: * -> *) (a :: *)) +# if MIN_VERSION_transformers(0,5,3) +deriving instance Generic (AccumT w m a) +deriving instance Generic (SelectT w m a) # endif -# endif # endif #endif diff --git a/tests/GenericsSpec.hs b/tests/GenericsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/GenericsSpec.hs @@ -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 diff --git a/tests/GenericsTypes.hs b/tests/GenericsTypes.hs new file mode 100644 --- /dev/null +++ b/tests/GenericsTypes.hs @@ -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) diff --git a/tests/LICENSE b/tests/LICENSE new file mode 100644 --- /dev/null +++ b/tests/LICENSE @@ -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. diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/transformers-compat-tests.cabal b/tests/transformers-compat-tests.cabal new file mode 100644 --- /dev/null +++ b/tests/transformers-compat-tests.cabal @@ -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 +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 diff --git a/transformers-compat.cabal b/transformers-compat.cabal --- a/transformers-compat.cabal +++ b/transformers-compat.cabal @@ -1,61 +1,88 @@ name: transformers-compat category: Compatibility -version: 0.5.1.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 stability: provisional -homepage: http://github.com/ekmett/transformers-compat/ -bug-reports: http://github.com/ekmett/transformers-compat/issues +homepage: https://github.com/ekmett/transformers-compat/ +bug-reports: https://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett -synopsis: A small compatibility shim exposing the new types from transformers 0.3 and 0.4 to older Haskell platforms. +synopsis: A small compatibility shim for the transformers library description: - This package includes backported versions of types that were added - to transformers in transformers 0.3, 0.4, and 0.5 for users who need strict - transformers 0.2 or 0.3 compatibility to run on old versions of the - platform, but also need those types. + This package includes backported versions of types that were added to + @transformers@ in @transformers-0.5@ for users who need strict + @transformers-0.5@ compatibility, but also need those types. . - Those users should be able to just depend on @transformers >= 0.2@ - and @transformers-compat >= 0.3@. + Those users should be able to just depend on @transformers >= 0.5@ and + @transformers-compat >= 0.7.3@. . Note: missing methods are not supplied, but this at least permits the types to be used. build-type: Simple -tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.8.2, GHC == 7.10.3, GHC == 8.0.1 +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 will be selected by cabal picking the appropriate version. - 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 will be selected by cabal picking the appropriate version. +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 @@ -66,34 +93,35 @@ 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.6 + 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: ghc-prim + 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