diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,202 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' -# -# To regenerate the script (for example after adjusting tested-with) run -# -# haskell-ci regenerate -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.10 -# -version: ~> 1.0 -language: c -os: linux -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -notifications: - irc: - channels: - - irc.freenode.org#haskell-lens - skip_join: true - template: - - "\x0313transformers-compat\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - - $HOME/.hlint -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -jobs: - include: - - compiler: ghc-8.10.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.8.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}} - os: linux - - compiler: ghc-7.10.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.2"]}} - os: linux - - compiler: ghc-7.8.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.2"]}} - os: linux - - compiler: ghc-7.6.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.2"]}} - os: linux - - compiler: ghc-7.4.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.2"]}} - os: linux - - compiler: ghc-7.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.2.2","cabal-install-3.2"]}} - os: linux - - compiler: ghc-7.0.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.0.4","cabal-install-3.2"]}} - os: linux -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - WITHCOMPILER="-w $HC" - - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap" - - set -o pipefail - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - "echo 'jobs: 2' >> $CABALHOME/config" - - | - echo "program-default-options" >> $CABALHOME/config - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ." >> cabal.project - echo "packages: ./tests" >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package transformers-compat' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package transformers-compat-tests' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(transformers-compat|transformers-compat-tests)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - if [ -f "./tests/configure.ac" ]; then (cd "./tests" && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_transformers_compat="$(find . -maxdepth 1 -type d -regex '.*/transformers-compat-[0-9.]*')" - - PKGDIR_transformers_compat_tests="$(find . -maxdepth 1 -type d -regex '.*/transformers-compat-tests-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_transformers_compat}" >> cabal.project - echo "packages: ${PKGDIR_transformers_compat_tests}" >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package transformers-compat' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package transformers-compat-tests' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(transformers-compat|transformers-compat-tests)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all - # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all - # cabal check... - - (cd ${PKGDIR_transformers_compat} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_transformers_compat_tests} && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - # Constraint sets - - rm -rf cabal.project.local - # Constraint set no-mtl - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers-compat -mtl' all - # Constraint set no-generic-deriving - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers-compat -generic-deriving' all - # Constraint set no-mtl-no-generic-deriving - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers-compat -generic-deriving' --constraint='tranformers-compat -mtl' all - # Constraint set two - - if [ $HCNUMVER -lt 71000 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers-compat +two' all ; fi - # Constraint set three - - if [ $HCNUMVER -lt 71000 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers-compat +three' all ; fi - # Constraint set four - - if [ $HCNUMVER -lt 80000 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers-compat +four' all ; fi - # Constraint set five - - if [ $HCNUMVER -lt 80400 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers-compat +five' all ; fi - # Constraint set transformers-installed - - if [ $HCNUMVER -ge 70800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers installed' all ; fi - # Constraint set transformers-newer - - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='transformers >=0.5.5.0' all ; fi - -# REGENDATA ("0.10",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) -# EOF 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,98 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif --- | --- Module : Control.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 - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Backwards f) where - liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y - {-# INLINE liftCompare #-} - -instance (Read1 f) => Read1 (Backwards f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards - -instance (Show1 f) => Show1 (Backwards f) where - liftShowsPrec sp sl d (Backwards x) = - showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x - -instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 - --- | Derived instance. -instance (Functor f) => Functor (Backwards f) where - fmap f (Backwards a) = Backwards (fmap f a) - {-# INLINE fmap #-} - --- | Apply @f@-actions in the reverse order. -instance (Applicative f) => Applicative (Backwards f) where - pure a = Backwards (pure a) - {-# INLINE pure #-} - Backwards f <*> Backwards a = Backwards (a <**> f) - {-# INLINE (<*>) #-} - --- | Try alternatives in the same order as @f@. -instance (Alternative f) => Alternative (Backwards f) where - empty = Backwards empty - {-# INLINE empty #-} - Backwards x <|> Backwards y = Backwards (x <|> y) - {-# INLINE (<|>) #-} - --- | Derived instance. -instance (Foldable f) => Foldable (Backwards f) where - foldMap f (Backwards t) = foldMap f t - {-# INLINE foldMap #-} - foldr f z (Backwards t) = foldr f z t - {-# INLINE foldr #-} - foldl f z (Backwards t) = foldl f z t - {-# INLINE foldl #-} - foldr1 f (Backwards t) = foldr1 f t - {-# INLINE foldr1 #-} - foldl1 f (Backwards t) = foldl1 f t - {-# INLINE foldl1 #-} - --- | Derived instance. -instance (Traversable f) => Traversable (Backwards f) where - traverse f (Backwards t) = fmap Backwards (traverse f t) - {-# INLINE traverse #-} - sequenceA (Backwards t) = fmap Backwards (sequenceA t) - {-# INLINE sequenceA #-} diff --git a/0.2/Control/Applicative/Lift.hs b/0.2/Control/Applicative/Lift.hs deleted file mode 100644 --- a/0.2/Control/Applicative/Lift.hs +++ /dev/null @@ -1,168 +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, - elimLift, - -- * Collecting errors - Errors, - runErrors, - failure, - eitherToErrors - ) where - -import Data.Functor.Classes - -import Control.Applicative -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Constant -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) - --- | 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 - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Lift f) where - liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 - liftCompare _ (Pure _) (Other _) = LT - liftCompare _ (Other _) (Pure _) = GT - liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 - {-# INLINE liftCompare #-} - -instance (Read1 f) => Read1 (Lift f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith rp "Pure" Pure `mappend` - readsUnaryWith (liftReadsPrec rp rl) "Other" Other - -instance (Show1 f) => Show1 (Lift f) where - liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x - liftShowsPrec sp sl d (Other y) = - showsUnaryWith (liftShowsPrec sp sl) "Other" d y - -instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 - -instance (Functor f) => Functor (Lift f) where - fmap f (Pure x) = Pure (f x) - fmap f (Other y) = Other (fmap f y) - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (Lift f) where - foldMap f (Pure x) = f x - foldMap f (Other y) = foldMap f y - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (Lift f) where - traverse f (Pure x) = Pure <$> f x - traverse f (Other y) = Other <$> traverse f y - {-# INLINE traverse #-} - --- | A combination is 'Pure' only if both parts are. -instance (Applicative f) => Applicative (Lift f) where - pure = Pure - {-# INLINE pure #-} - Pure f <*> 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) - {-# INLINE (<*>) #-} - --- | A combination is 'Pure' only either part is. -instance (Alternative f) => Alternative (Lift f) where - empty = Other empty - {-# INLINE empty #-} - Pure x <|> _ = Pure x - Other _ <|> Pure y = Pure y - Other x <|> Other y = Other (x <|> y) - {-# INLINE (<|>) #-} - --- | Projection to the other functor. -unLift :: (Applicative f) => Lift f a -> f a -unLift (Pure x) = pure x -unLift (Other e) = e -{-# INLINE unLift #-} - --- | Apply a transformation to the other computation. -mapLift :: (f a -> g a) -> Lift f a -> Lift g a -mapLift _ (Pure x) = Pure x -mapLift f (Other e) = Other (f e) -{-# INLINE mapLift #-} - --- | Eliminator for 'Lift'. --- --- * @'elimLift' f g . 'pure' = f@ --- --- * @'elimLift' f g . 'Other' = g@ --- -elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r -elimLift f _ (Pure x) = f x -elimLift _ g (Other e) = g e -{-# INLINE elimLift #-} - --- | An applicative functor that collects a monoid (e.g. lists) of errors. --- A sequence of computations fails if any of its components do, but --- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except", --- these computations continue after an error, collecting all the errors. --- --- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@ --- --- * @'pure' f '<*>' 'failure' e = 'failure' e@ --- --- * @'failure' e '<*>' 'pure' x = 'failure' e@ --- --- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@ --- -type Errors e = Lift (Constant e) - --- | Extractor for computations with accumulating errors. --- --- * @'runErrors' ('pure' x) = 'Right' x@ --- --- * @'runErrors' ('failure' e) = 'Left' e@ --- -runErrors :: Errors e a -> Either e a -runErrors (Other (Constant e)) = Left e -runErrors (Pure x) = Right x -{-# INLINE runErrors #-} - --- | Report an error. -failure :: e -> Errors e a -failure e = Other (Constant e) -{-# INLINE failure #-} - --- | Convert from 'Either' to 'Errors' (inverse of 'runErrors'). -eitherToErrors :: Either e a -> Errors e a -eitherToErrors = either failure Pure diff --git a/0.2/Data/Functor/Reverse.hs b/0.2/Data/Functor/Reverse.hs deleted file mode 100644 --- a/0.2/Data/Functor/Reverse.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif --- | --- Module : Data.Functor.Reverse --- Copyright : (c) Russell O'Connor 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Making functors whose elements are notionally in the reverse order --- from the original functor. --- --- /NB:/ Note this module is only included in @lens@ for backwards --- compatibility with older @containers@ versions. - -module Data.Functor.Reverse where - -import Control.Applicative.Backwards -import Data.Functor.Classes - -import Prelude hiding (foldr, foldr1, foldl, foldl1) -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Data.Foldable -import Data.Traversable -import Data.Monoid - --- | 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 - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Reverse f) where - liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y - {-# INLINE liftCompare #-} - -instance (Read1 f) => Read1 (Reverse f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse - -instance (Show1 f) => Show1 (Reverse f) where - liftShowsPrec sp sl d (Reverse x) = - showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x - -instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 - --- | Derived instance. -instance (Functor f) => Functor (Reverse f) where - fmap f (Reverse a) = Reverse (fmap f a) - {-# INLINE fmap #-} - --- | Derived instance. -instance (Applicative f) => Applicative (Reverse f) where - pure a = Reverse (pure a) - {-# INLINE pure #-} - Reverse f <*> Reverse a = Reverse (f <*> a) - {-# INLINE (<*>) #-} - --- | Derived instance. -instance (Alternative f) => Alternative (Reverse f) where - empty = Reverse empty - {-# INLINE empty #-} - Reverse x <|> Reverse y = Reverse (x <|> y) - {-# INLINE (<|>) #-} - --- | Derived instance. -instance (Monad m) => Monad (Reverse m) where - return a = Reverse (return a) - {-# INLINE return #-} - m >>= f = Reverse (getReverse m >>= getReverse . f) - {-# INLINE (>>=) #-} - fail msg = Reverse (fail msg) - {-# INLINE fail #-} - --- | Derived instance. -instance (MonadPlus m) => MonadPlus (Reverse m) where - mzero = Reverse mzero - {-# INLINE mzero #-} - Reverse x `mplus` Reverse y = Reverse (x `mplus` y) - {-# INLINE mplus #-} - --- | Fold from right to left. -instance (Foldable f) => Foldable (Reverse f) where - foldMap f (Reverse t) = getDual (foldMap (Dual . f) t) - {-# INLINE foldMap #-} - foldr f z (Reverse t) = foldl (flip f) z t - {-# INLINE foldr #-} - foldl f z (Reverse t) = foldr (flip f) z t - {-# INLINE foldl #-} - foldr1 f (Reverse t) = foldl1 (flip f) t - {-# INLINE foldr1 #-} - foldl1 f (Reverse t) = foldr1 (flip f) t - {-# INLINE foldl1 #-} - --- | Traverse from right to left. -instance (Traversable f) => Traversable (Reverse f) where - traverse f (Reverse t) = - fmap Reverse . forwards $ traverse (Backwards . f) t - {-# INLINE traverse #-} - sequenceA (Reverse t) = - fmap Reverse . forwards $ sequenceA (fmap Backwards t) - {-# INLINE sequenceA #-} diff --git a/0.3/Control/Monad/Signatures.hs b/0.3/Control/Monad/Signatures.hs deleted file mode 100644 --- a/0.3/Control/Monad/Signatures.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Signatures --- Copyright : (c) Ross Paterson 2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Signatures for monad operations that require specialized lifting. --- Each signature has a uniformity property that the lifting should satisfy. ------------------------------------------------------------------------------ - -module Control.Monad.Signatures ( - CallCC, Catch, Listen, Pass - ) where - --- | Signature of the @callCC@ operation, --- introduced in "Control.Monad.Trans.Cont". --- Any lifting function @liftCallCC@ should satisfy --- --- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@ --- -type CallCC m a b = ((a -> m b) -> m a) -> m a - --- | Signature of the @catchE@ operation, --- introduced in "Control.Monad.Trans.Except". --- Any lifting function @liftCatch@ should satisfy --- --- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@ --- -type Catch e m a = m a -> (e -> m a) -> m a - --- | Signature of the @listen@ operation, --- introduced in "Control.Monad.Trans.Writer". --- Any lifting function @liftListen@ should satisfy --- --- * @'lift' . liftListen = liftListen . 'lift'@ --- -type Listen w m a = m a -> m (a, w) - --- | Signature of the @pass@ operation, --- introduced in "Control.Monad.Trans.Writer". --- Any lifting function @liftPass@ should satisfy --- --- * @'lift' . liftPass = liftPass . 'lift'@ --- -type Pass w m a = m (a, w -> w) -> m a diff --git a/0.3/Control/Monad/Trans/Except.hs b/0.3/Control/Monad/Trans/Except.hs deleted file mode 100644 --- a/0.3/Control/Monad/Trans/Except.hs +++ /dev/null @@ -1,350 +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 - -#ifdef MTL -{-# 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 qualified Control.Monad.Fail as Fail -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif - -#ifdef MTL -import Control.Monad.Writer.Class -import Control.Monad.State.Class -import Control.Monad.Reader.Class -import Control.Monad.Cont.Class -import Control.Monad.Error.Class -import Control.Monad.RWS.Class -#endif - -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Classes -import Data.Functor.Identity -import Data.Monoid -import Data.Traversable (Traversable(traverse)) - --- | The parameterizable exception monad. --- --- Computations are either exceptions or normal values. --- --- The 'return' function returns a normal value, while @>>=@ exits --- on the first exception. -type Except e = ExceptT e Identity - --- | Constructor for computations in the exception monad. --- (The inverse of 'runExcept'). -except :: (Monad m) => Either e a -> ExceptT e m a -except m = ExceptT (return m) -{-# INLINE except #-} - --- | Extractor for computations in the exception monad. --- (The inverse of 'except'). -runExcept :: Except e a -> Either e a -runExcept (ExceptT m) = runIdentity m -{-# INLINE runExcept #-} - --- | Map the unwrapped computation using the given function. --- --- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@ -mapExcept :: (Either e a -> Either e' b) - -> Except e a - -> Except e' b -mapExcept f = mapExceptT (Identity . f . runIdentity) -{-# INLINE mapExcept #-} - --- | Transform any exceptions thrown by the computation using the given --- function (a specialization of 'withExceptT'). -withExcept :: (e -> e') -> Except e a -> Except e' a -withExcept = withExceptT -{-# INLINE withExcept #-} - --- | A monad transformer that adds exceptions to other monads. --- --- @ExceptT@ constructs a monad parameterized over two things: --- --- * e - The exception type. --- --- * m - The inner monad. --- --- The 'return' function yields a computation that produces the given --- value, while @>>=@ sequences two subcomputations, exiting on the --- first exception. -newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } - -instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where - liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y - {-# INLINE liftEq #-} - -instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where - liftCompare comp (ExceptT x) (ExceptT y) = - liftCompare (liftCompare comp) x y - {-# INLINE liftCompare #-} - -instance (Read e, Read1 m) => Read1 (ExceptT e m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show e, Show1 m) => Show1 (ExceptT e m) where - liftShowsPrec sp sl d (ExceptT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1 -instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1 -instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where - readsPrec = readsPrec1 -instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where - showsPrec = showsPrec1 - --- | Map the unwrapped computation using the given function. --- --- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ -mapExceptT :: (m (Either e a) -> n (Either e' b)) - -> ExceptT e m a - -> ExceptT e' n b -mapExceptT f m = ExceptT $ f (runExceptT m) -{-# INLINE mapExceptT #-} - --- | Transform any exceptions thrown by the computation using the --- given function. -withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a -withExceptT f = mapExceptT $ fmap $ either (Left . f) Right -{-# INLINE withExceptT #-} - -instance (Functor m) => Functor (ExceptT e m) where - fmap f = ExceptT . fmap (fmap f) . runExceptT - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (ExceptT e f) where - foldMap f (ExceptT a) = foldMap (either (const mempty) f) a - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (ExceptT e f) where - traverse f (ExceptT a) = - ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a - {-# INLINE traverse #-} - -instance (Functor m, Monad m) => Applicative (ExceptT e m) where - pure a = ExceptT $ return (Right a) - {-# INLINE pure #-} - ExceptT f <*> ExceptT v = ExceptT $ do - mf <- f - case mf of - Left e -> return (Left e) - Right k -> do - mv <- v - case mv of - Left e -> return (Left e) - Right x -> return (Right (k x)) - {-# INLINEABLE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where - empty = ExceptT $ return (Left mempty) - {-# INLINE empty #-} - ExceptT mx <|> ExceptT my = ExceptT $ do - ex <- mx - case ex of - Left e -> liftM (either (Left . mappend e) Right) my - Right x -> return (Right x) - {-# INLINEABLE (<|>) #-} - -instance (Monad m) => Monad (ExceptT e m) where - return a = ExceptT $ return (Right a) - {-# INLINE return #-} - m >>= k = ExceptT $ do - a <- runExceptT m - case a of - Left e -> return (Left e) - Right x -> runExceptT (k x) - {-# INLINE (>>=) #-} - fail = ExceptT . fail - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where - fail = ExceptT . Fail.fail - {-# INLINE fail #-} - -instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where - mzero = ExceptT $ return (Left mempty) - {-# INLINE mzero #-} - ExceptT m `mplus` ExceptT n = ExceptT $ do - a <- m - case a of - Left e -> liftM (either (Left . mappend e) Right) n - Right x -> return (Right x) - {-# INLINEABLE mplus #-} - -instance (MonadFix m) => MonadFix (ExceptT e m) where - mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id)) - where bomb = error "mfix (ExceptT): inner computation returned Left value" - {-# INLINE mfix #-} - -instance MonadTrans (ExceptT e) where - lift = ExceptT . liftM Right - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (ExceptT e m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (ExceptT e m) where - mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b - {-# INLINE mzipWith #-} -#endif - --- | Signal an exception value @e@. --- --- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@ --- --- * @'throwE' e >>= m = 'throwE' e@ -throwE :: (Monad m) => e -> ExceptT e m a -throwE = ExceptT . return . Left -{-# INLINE throwE #-} - --- | Handle an exception. --- --- * @'catchE' h ('lift' m) = 'lift' m@ --- --- * @'catchE' h ('throwE' e) = h e@ -catchE :: (Monad m) => - ExceptT e m a -- ^ the inner computation - -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner - -- computation - -> ExceptT e' m a -m `catchE` h = ExceptT $ do - a <- runExceptT m - case a of - Left l -> runExceptT (h l) - Right r -> return (Right r) -{-# INLINE catchE #-} - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b -liftCallCC callCC f = ExceptT $ - callCC $ \ c -> - runExceptT (f (\ a -> ExceptT $ c (Right a))) -{-# INLINE liftCallCC #-} - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a -liftListen listen = mapExceptT $ \ m -> do - (a, w) <- listen m - return $! fmap (\ r -> (r, w)) a -{-# INLINE liftListen #-} - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a -liftPass pass = mapExceptT $ \ m -> pass $ do - a <- m - return $! case a of - Left l -> (Left l, id) - Right (r, f) -> (Right r, f) -{-# INLINE liftPass #-} - --- incurring the mtl dependency for these avoids packages that need them introducing orphans. - -#ifdef MTL - -instance Monad m => MonadError e (ExceptT e m) where - throwError = throwE - catchError = catchE - -instance MonadWriter w m => MonadWriter w (ExceptT e m) where - tell = lift . tell - listen = liftListen listen - pass = liftPass pass -#if MIN_VERSION_mtl(2,1,0) - writer = lift . writer -#endif - -instance MonadState s m => MonadState s (ExceptT e m) where - get = lift get - put = lift . put -#if MIN_VERSION_mtl(2,1,0) - state = lift . state -#endif - -instance MonadReader r m => MonadReader r (ExceptT e m) where - ask = lift ask - local = mapExceptT . local -#if MIN_VERSION_mtl(2,1,0) - reader = lift . reader -#endif - -instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m) - -instance MonadCont m => MonadCont (ExceptT e m) where - callCC = liftCallCC callCC - -#endif diff --git a/0.3/Data/Functor/Classes.hs b/0.3/Data/Functor/Classes.hs deleted file mode 100644 --- a/0.3/Data/Functor/Classes.hs +++ /dev/null @@ -1,857 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(a,b,c) 1 -#endif - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -# endif -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Classes --- Copyright : (c) Ross Paterson 2013, Edward Kmett 2014 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to --- unary and binary type constructors. --- --- These classes are needed to express the constraints on arguments of --- transformers in portable Haskell. Thus for a new transformer @T@, --- one might write instances like --- --- > instance (Eq1 f) => Eq1 (T f) where ... --- > instance (Ord1 f) => Ord1 (T f) where ... --- > instance (Read1 f) => Read1 (T f) where ... --- > instance (Show1 f) => Show1 (T f) where ... --- --- If these instances can be defined, defining instances of the base --- classes is mechanical: --- --- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 --- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 --- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1 --- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 --- ------------------------------------------------------------------------------ - -module Data.Functor.Classes ( - -- * Liftings of Prelude classes - -- ** For unary constructors - Eq1(..), eq1, - Ord1(..), compare1, - Read1(..), readsPrec1, - Show1(..), showsPrec1, - -- ** For binary constructors - Eq2(..), eq2, - Ord2(..), compare2, - Read2(..), readsPrec2, - Show2(..), showsPrec2, - -- * Helper functions - -- $example - readsData, - readsUnaryWith, - readsBinaryWith, - showsUnaryWith, - showsBinaryWith, - -- ** Obsolete helpers - readsUnary, - readsUnary1, - readsBinary1, - showsUnary, - showsUnary1, - showsBinary1, - ) where - -import Control.Applicative (Const(Const)) -import Data.Functor.Identity (Identity(Identity)) -import Data.Monoid (mappend) -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy(Proxy)) -#endif -import Text.Show (showListWith) - -import Control.Monad.Trans.Error -import Control.Monad.Trans.Identity -import Control.Monad.Trans.List -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Data.Functor.Compose -import Data.Functor.Constant -import Data.Functor.Product - -#if MIN_VERSION_transformers(0,3,0) -import Control.Applicative.Lift -import Control.Applicative.Backwards -import Data.Functor.Reverse -#endif - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -# endif -#endif - --- | Lifting of the 'Eq' class to unary type constructors. -class Eq1 f where - -- | Lift an equality test through the type constructor. - -- - -- The function will usually be applied to an equality function, - -- but the more general type ensures that the implementation uses - -- it to compare elements of the first container with elements of - -- the second. - liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool - --- | Lift the standard @('==')@ function through the type constructor. -eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool -eq1 = liftEq (==) - --- | Lifting of the 'Ord' class to unary type constructors. -class (Eq1 f) => Ord1 f where - -- | Lift a 'compare' function through the type constructor. - -- - -- The function will usually be applied to a comparison function, - -- but the more general type ensures that the implementation uses - -- it to compare elements of the first container with elements of - -- the second. - liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering - --- | Lift the standard 'compare' function through the type constructor. -compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering -compare1 = liftCompare compare - --- | Lifting of the 'Read' class to unary type constructors. -class Read1 f where - -- | 'readsPrec' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument type. - liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) - - -- | 'readList' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument type. - -- The default implementation using standard list syntax is correct - -- for most types. - liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] - liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) - --- | Read a list (using square brackets and commas), given a function --- for reading elements. -readListWith :: ReadS a -> ReadS [a] -readListWith rp = - readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) - where - readl s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] - readl' s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] - --- | Lift the standard 'readsPrec' and 'readList' functions through the --- type constructor. -readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) -readsPrec1 = liftReadsPrec readsPrec readList - --- | Lifting of the 'Show' class to unary type constructors. -class Show1 f where - -- | 'showsPrec' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument type. - liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - Int -> f a -> ShowS - - -- | 'showList' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument type. - -- The default implementation using standard list syntax is correct - -- for most types. - liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - [f a] -> ShowS - liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) - --- | Lift the standard 'showsPrec' and 'showList' functions through the --- type constructor. -showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS -showsPrec1 = liftShowsPrec showsPrec showList - --- | Lifting of the 'Eq' class to binary type constructors. -class Eq2 f where - -- | Lift equality tests through the type constructor. - -- - -- The function will usually be applied to equality functions, - -- but the more general type ensures that the implementation uses - -- them to compare elements of the first container with elements of - -- the second. - liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool - --- | Lift the standard @('==')@ function through the type constructor. -eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool -eq2 = liftEq2 (==) (==) - --- | Lifting of the 'Ord' class to binary type constructors. -class (Eq2 f) => Ord2 f where - -- | Lift 'compare' functions through the type constructor. - -- - -- The function will usually be applied to comparison functions, - -- but the more general type ensures that the implementation uses - -- them to compare elements of the first container with elements of - -- the second. - liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> - f a c -> f b d -> Ordering - --- | Lift the standard 'compare' function through the type constructor. -compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering -compare2 = liftCompare2 compare compare - --- | Lifting of the 'Read' class to binary type constructors. -class Read2 f where - -- | 'readsPrec' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument types. - liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> - (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) - - -- | 'readList' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument types. - -- The default implementation using standard list syntax is correct - -- for most types. - liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> - (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] - liftReadList2 rp1 rl1 rp2 rl2 = - readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) - --- | Lift the standard 'readsPrec' function through the type constructor. -readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) -readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList - --- | Lifting of the 'Show' class to binary type constructors. -class Show2 f where - -- | 'showsPrec' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument types. - liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS - - -- | 'showList' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument types. - -- The default implementation using standard list syntax is correct - -- for most types. - liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS - liftShowList2 sp1 sl1 sp2 sl2 = - showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) - --- | Lift the standard 'showsPrec' function through the type constructor. -showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS -showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList - --- Instances for Prelude type constructors - -instance Eq1 Maybe where - liftEq _ Nothing Nothing = True - liftEq _ Nothing (Just _) = False - liftEq _ (Just _) Nothing = False - liftEq eq (Just x) (Just y) = eq x y - -instance Ord1 Maybe where - liftCompare _ Nothing Nothing = EQ - liftCompare _ Nothing (Just _) = LT - liftCompare _ (Just _) Nothing = GT - liftCompare comp (Just x) (Just y) = comp x y - -instance Read1 Maybe where - liftReadsPrec rp _ d = - readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) - `mappend` - readsData (readsUnaryWith rp "Just" Just) d - -instance Show1 Maybe where - liftShowsPrec _ _ _ Nothing = showString "Nothing" - liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x - -instance Eq1 [] where - liftEq _ [] [] = True - liftEq _ [] (_:_) = False - liftEq _ (_:_) [] = False - liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys - -instance Ord1 [] where - liftCompare _ [] [] = EQ - liftCompare _ [] (_:_) = LT - liftCompare _ (_:_) [] = GT - liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys - -instance Read1 [] where - liftReadsPrec _ rl _ = rl - -instance Show1 [] where - liftShowsPrec _ sl _ = sl - -instance Eq2 (,) where - liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 - -instance Ord2 (,) where - liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = - comp1 x1 x2 `mappend` comp2 y1 y2 - -instance Read2 (,) where - liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> - [((x,y), w) | ("(",s) <- lex r, - (x,t) <- rp1 0 s, - (",",u) <- lex t, - (y,v) <- rp2 0 u, - (")",w) <- lex v] - -instance Show2 (,) where - liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = - showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' - -instance (Eq a) => Eq1 ((,) a) where - liftEq = liftEq2 (==) - -instance (Ord a) => Ord1 ((,) a) where - liftCompare = liftCompare2 compare - -instance (Read a) => Read1 ((,) a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a) => Show1 ((,) a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Eq2 Either where - liftEq2 e1 _ (Left x) (Left y) = e1 x y - liftEq2 _ _ (Left _) (Right _) = False - liftEq2 _ _ (Right _) (Left _) = False - liftEq2 _ e2 (Right x) (Right y) = e2 x y - -instance Ord2 Either where - liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y - liftCompare2 _ _ (Left _) (Right _) = LT - liftCompare2 _ _ (Right _) (Left _) = GT - liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y - -instance Read2 Either where - liftReadsPrec2 rp1 _ rp2 _ = readsData $ - readsUnaryWith rp1 "Left" Left `mappend` - readsUnaryWith rp2 "Right" Right - -instance Show2 Either where - liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x - liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x - -instance (Eq a) => Eq1 (Either a) where - liftEq = liftEq2 (==) - -instance (Ord a) => Ord1 (Either a) where - liftCompare = liftCompare2 compare - -instance (Read a) => Read1 (Either a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a) => Show1 (Either a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - --- Instances for other functors defined in the base package - -instance Eq1 Identity where - liftEq eq (Identity x) (Identity y) = eq x y - -instance Ord1 Identity where - liftCompare comp (Identity x) (Identity y) = comp x y - -instance Read1 Identity where - liftReadsPrec rp _ = readsData $ - readsUnaryWith rp "Identity" Identity - -instance Show1 Identity where - liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x - -instance Eq2 Const where - liftEq2 eq _ (Const x) (Const y) = eq x y - -instance Ord2 Const where - liftCompare2 comp _ (Const x) (Const y) = comp x y - -instance Read2 Const where - liftReadsPrec2 rp _ _ _ = readsData $ - readsUnaryWith rp "Const" Const - -instance Show2 Const where - liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x - -instance (Eq a) => Eq1 (Const a) where - liftEq = liftEq2 (==) -instance (Ord a) => Ord1 (Const a) where - liftCompare = liftCompare2 compare -instance (Read a) => Read1 (Const a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList -instance (Show a) => Show1 (Const a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -#if MIN_VERSION_base(4,7,0) -instance Eq1 Proxy where - liftEq _ _ _ = True - -instance Ord1 Proxy where - liftCompare _ _ _ = EQ - -instance Show1 Proxy where - liftShowsPrec _ _ _ _ = showString "Proxy" - -instance Read1 Proxy where - liftReadsPrec _ _ d = - readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) -#endif - --- Building blocks - --- | @'readsData' p d@ is a parser for datatypes where each alternative --- begins with a data constructor. It parses the constructor and --- passes it to @p@. Parsers for various constructors can be constructed --- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with --- @mappend@ from the @Monoid@ class. -readsData :: (String -> ReadS a) -> Int -> ReadS a -readsData reader d = - readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] - --- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor --- and then parses its argument using @rp@. -readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t -readsUnaryWith rp name cons kw s = - [(cons x,t) | kw == name, (x,t) <- rp 11 s] - --- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary --- data constructor and then parses its arguments using @rp1@ and @rp2@ --- respectively. -readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> - String -> (a -> b -> t) -> String -> ReadS t -readsBinaryWith rp1 rp2 name cons kw s = - [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] - --- | @'showsUnaryWith' sp n d x@ produces the string representation of a --- unary data constructor with name @n@ and argument @x@, in precedence --- context @d@. -showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS -showsUnaryWith sp name d x = showParen (d > 10) $ - showString name . showChar ' ' . sp 11 x - --- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string --- representation of a binary data constructor with name @n@ and arguments --- @x@ and @y@, in precedence context @d@. -showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> - String -> Int -> a -> b -> ShowS -showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ - showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y - --- Obsolete building blocks - --- | @'readsUnary' n c n'@ matches the name of a unary data constructor --- and then parses its argument using 'readsPrec'. -{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} -readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t -readsUnary name cons kw s = - [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] - --- | @'readsUnary1' n c n'@ matches the name of a unary data constructor --- and then parses its argument using 'readsPrec1'. -{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} -readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t -readsUnary1 name cons kw s = - [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] - --- | @'readsBinary1' n c n'@ matches the name of a binary data constructor --- and then parses its arguments using 'readsPrec1'. -{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} -readsBinary1 :: (Read1 f, Read1 g, Read a) => - String -> (f a -> g a -> t) -> String -> ReadS t -readsBinary1 name cons kw s = - [(cons x y,u) | kw == name, - (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] - --- | @'showsUnary' n d x@ produces the string representation of a unary data --- constructor with name @n@ and argument @x@, in precedence context @d@. -{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} -showsUnary :: (Show a) => String -> Int -> a -> ShowS -showsUnary name d x = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec 11 x - --- | @'showsUnary1' n d x@ produces the string representation of a unary data --- constructor with name @n@ and argument @x@, in precedence context @d@. -{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} -showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS -showsUnary1 name d x = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec1 11 x - --- | @'showsBinary1' n d x y@ produces the string representation of a binary --- data constructor with name @n@ and arguments @x@ and @y@, in precedence --- context @d@. -{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} -showsBinary1 :: (Show1 f, Show1 g, Show a) => - String -> Int -> f a -> g a -> ShowS -showsBinary1 name d x y = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec1 11 x . - showChar ' ' . showsPrec1 11 y - - -instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where - liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y - -instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where - liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y - -instance (Read e, Read1 m) => Read1 (ErrorT e m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show e, Show1 m) => Show1 (ErrorT e m) where - liftShowsPrec sp sl d (ErrorT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1 -instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1 -instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where - readsPrec = readsPrec1 -instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where - showsPrec = showsPrec1 - -instance (Eq1 f) => Eq1 (IdentityT f) where - liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (IdentityT f) where - liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y - -instance (Read1 f) => Read1 (IdentityT f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT - -instance (Show1 f) => Show1 (IdentityT f) where - liftShowsPrec sp sl d (IdentityT m) = - showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m - -instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1 -instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1 - -instance (Eq1 m) => Eq1 (ListT m) where - liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y - -instance (Ord1 m) => Ord1 (ListT m) where - liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y - -instance (Read1 m) => Read1 (ListT m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 m) => Show1 (ListT m) where - liftShowsPrec sp sl d (ListT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1 -instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1 -instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1 -instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 - -instance (Eq1 m) => Eq1 (MaybeT m) where - liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y - -instance (Ord1 m) => Ord1 (MaybeT m) where - liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y - -instance (Read1 m) => Read1 (MaybeT m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 m) => Show1 (MaybeT m) where - liftShowsPrec sp sl d (MaybeT m) = - showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1 -instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1 -instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1 -instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 - -instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where - liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) = - liftEq (liftEq2 eq (==)) m1 m2 - -instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where - liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) = - liftCompare (liftCompare2 comp compare) m1 m2 - -instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT - where - rp' = liftReadsPrec2 rp rl readsPrec readList - rl' = liftReadList2 rp rl readsPrec readList - -instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where - liftShowsPrec sp sl d (Lazy.WriterT m) = - showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m - where - sp' = liftShowsPrec2 sp sl showsPrec showList - sl' = liftShowList2 sp sl showsPrec showList - -instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where - (==) = eq1 -instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where - compare = compare1 -instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where - readsPrec = readsPrec1 -instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where - showsPrec = showsPrec1 - -instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where - liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) = - liftEq (liftEq2 eq (==)) m1 m2 - -instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where - liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) = - liftCompare (liftCompare2 comp compare) m1 m2 - -instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT - where - rp' = liftReadsPrec2 rp rl readsPrec readList - rl' = liftReadList2 rp rl readsPrec readList - -instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where - liftShowsPrec sp sl d (Strict.WriterT m) = - showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m - where - sp' = liftShowsPrec2 sp sl showsPrec showList - sl' = liftShowList2 sp sl showsPrec showList - -instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where - (==) = eq1 -instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where - compare = compare1 -instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where - readsPrec = readsPrec1 -instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where - showsPrec = showsPrec1 - -instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where - liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y - -instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where - liftCompare comp (Compose x) (Compose y) = - liftCompare (liftCompare comp) x y - -instance (Read1 f, Read1 g) => Read1 (Compose f g) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 f, Show1 g) => Show1 (Compose f g) where - liftShowsPrec sp sl d (Compose x) = - showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where - (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where - showsPrec = showsPrec1 - -instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where - liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 - -instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where - liftCompare comp (Pair x1 y1) (Pair x2 y2) = - liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 - -instance (Read1 f, Read1 g) => Read1 (Product f g) where - liftReadsPrec rp rl = readsData $ - readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair - -instance (Show1 f, Show1 g) => Show1 (Product f g) where - liftShowsPrec sp sl d (Pair x y) = - showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) - where (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where - showsPrec = showsPrec1 - -instance Eq2 Constant where - liftEq2 eq _ (Constant x) (Constant y) = eq x y -instance Ord2 Constant where - liftCompare2 comp _ (Constant x) (Constant y) = comp x y -instance Read2 Constant where - liftReadsPrec2 rp _ _ _ = readsData $ - readsUnaryWith rp "Constant" Constant -instance Show2 Constant where - liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x - -instance (Eq a) => Eq1 (Constant a) where - liftEq = liftEq2 (==) -instance (Ord a) => Ord1 (Constant a) where - liftCompare = liftCompare2 compare -instance (Read a) => Read1 (Constant a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList -instance (Show a) => Show1 (Constant a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Eq a => Eq (Constant a b) where - Constant a == Constant b = a == b -instance Ord a => Ord (Constant a b) where - compare (Constant a) (Constant b) = compare a b -instance (Read a) => Read (Constant a b) where - readsPrec = readsData $ - readsUnaryWith readsPrec "Constant" Constant -instance (Show a) => Show (Constant a b) where - showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x - -instance Show a => Show (Identity a) where - showsPrec d (Identity a) = showParen (d > 10) $ - showString "Identity " . showsPrec 11 a -instance Read a => Read (Identity a) where - readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s]) -instance Eq a => Eq (Identity a) where - Identity a == Identity b = a == b -instance Ord a => Ord (Identity a) where - compare (Identity a) (Identity b) = compare a b - -#if MIN_VERSION_transformers(0,3,0) -instance (Eq1 f) => Eq1 (Lift f) where - liftEq eq (Pure x1) (Pure x2) = eq x1 x2 - liftEq _ (Pure _) (Other _) = False - liftEq _ (Other _) (Pure _) = False - liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 - -instance (Ord1 f) => Ord1 (Lift f) where - liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 - liftCompare _ (Pure _) (Other _) = LT - liftCompare _ (Other _) (Pure _) = GT - liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 - -instance (Read1 f) => Read1 (Lift f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith rp "Pure" Pure `mappend` - readsUnaryWith (liftReadsPrec rp rl) "Other" Other - -instance (Show1 f) => Show1 (Lift f) where - liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x - liftShowsPrec sp sl d (Other y) = - showsUnaryWith (liftShowsPrec sp sl) "Other" d y - -instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 - -instance (Eq1 f) => Eq1 (Backwards f) where - liftEq eq (Backwards x) (Backwards y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (Backwards f) where - liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y - -instance (Read1 f) => Read1 (Backwards f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards - -instance (Show1 f) => Show1 (Backwards f) where - liftShowsPrec sp sl d (Backwards x) = - showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x - -instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 - -instance (Eq1 f) => Eq1 (Reverse f) where - liftEq eq (Reverse x) (Reverse y) = liftEq eq x y - -instance (Ord1 f) => Ord1 (Reverse f) where - liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y - -instance (Read1 f) => Read1 (Reverse f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse - -instance (Show1 f) => Show1 (Reverse f) where - liftShowsPrec sp sl d (Reverse x) = - showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x - -instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 -#endif - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Eq1 -deriving instance Typeable Eq2 -deriving instance Typeable Ord1 -deriving instance Typeable Ord2 -deriving instance Typeable Read1 -deriving instance Typeable Read2 -deriving instance Typeable Show1 -deriving instance Typeable Show2 -# endif -#endif - -{- $example -These functions can be used to assemble 'Read' and 'Show' instances for -new algebraic types. For example, given the definition - -> data T f a = Zero a | One (f a) | Two a (f a) - -a standard 'Read1' instance may be defined as - -> instance (Read1 f) => Read1 (T f) where -> liftReadsPrec rp rl = readsData $ -> readsUnaryWith rp "Zero" Zero `mappend` -> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` -> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two - -and the corresponding 'Show1' instance as - -> instance (Show1 f) => Show1 (T f) where -> liftShowsPrec sp _ d (Zero x) = -> showsUnaryWith sp "Zero" d x -> liftShowsPrec sp sl d (One x) = -> showsUnaryWith (liftShowsPrec sp sl) "One" d x -> liftShowsPrec sp sl d (Two x y) = -> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y - --} diff --git a/0.3/Data/Functor/Sum.hs b/0.3/Data/Functor/Sum.hs deleted file mode 100644 --- a/0.3/Data/Functor/Sum.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE CPP #-} - -#ifndef HASKELL98 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -# if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} -# endif -#endif --- | --- Module : Data.Functor.Sum --- Copyright : (c) Ross Paterson 2014 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- Sums, lifted to functors. - -module Data.Functor.Sum ( - Sum(..), - ) where - -import Control.Applicative -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Classes -import Data.Monoid (mappend) -import Data.Traversable (Traversable(traverse)) - -#ifndef HASKELL98 -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -# endif -# if __GLASGOW_HASKELL__ >= 708 -import Data.Data -# endif -#endif - --- | Lifted sum of functors. -data Sum f g a = InL (f a) | InR (g a) - -#ifndef HASKELL98 -# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) --- Generic(1) instances for Sum -instance Generic (Sum f g a) where - type Rep (Sum f g a) = - D1 MDSum (C1 MCInL (S1 NoSelector (Rec0 (f a))) - :+: C1 MCInR (S1 NoSelector (Rec0 (g a)))) - from (InL f) = M1 (L1 (M1 (M1 (K1 f)))) - from (InR g) = M1 (R1 (M1 (M1 (K1 g)))) - to (M1 (L1 (M1 (M1 (K1 f))))) = InL f - to (M1 (R1 (M1 (M1 (K1 g))))) = InR g - -instance Generic1 (Sum f g) where - type Rep1 (Sum f g) = - D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f)) - :+: C1 MCInR (S1 NoSelector (Rec1 g))) - from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f)))) - from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g)))) - to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f) - to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) - -data MDSum -data MCInL -data MCInR - -instance Datatype MDSum where - datatypeName _ = "Sum" - moduleName _ = "Data.Functor.Sum" - -instance Constructor MCInL where - conName _ = "InL" - -instance Constructor MCInR where - conName _ = "InR" -# endif - -# if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Sum -deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) - => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) -# endif -#endif - -instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where - liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 - liftEq _ (InL _) (InR _) = False - liftEq _ (InR _) (InL _) = False - liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 - -instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where - liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 - liftCompare _ (InL _) (InR _) = LT - liftCompare _ (InR _) (InL _) = GT - liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 - -instance (Read1 f, Read1 g) => Read1 (Sum f g) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` - readsUnaryWith (liftReadsPrec rp rl) "InR" InR - -instance (Show1 f, Show1 g) => Show1 (Sum f g) where - liftShowsPrec sp sl d (InL x) = - showsUnaryWith (liftShowsPrec sp sl) "InL" d x - liftShowsPrec sp sl d (InR y) = - showsUnaryWith (liftShowsPrec sp sl) "InR" d y - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where - (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where - showsPrec = showsPrec1 - -instance (Functor f, Functor g) => Functor (Sum f g) where - fmap f (InL x) = InL (fmap f x) - fmap f (InR y) = InR (fmap f y) - -instance (Foldable f, Foldable g) => Foldable (Sum f g) where - foldMap f (InL x) = foldMap f x - foldMap f (InR y) = foldMap f y - -instance (Traversable f, Traversable g) => Traversable (Sum f g) where - traverse f (InL x) = InL <$> traverse f x - traverse f (InR y) = InR <$> traverse f y diff --git a/0.5/Control/Monad/Trans/Accum.hs b/0.5/Control/Monad/Trans/Accum.hs --- a/0.5/Control/Monad/Trans/Accum.hs +++ b/0.5/Control/Monad/Trans/Accum.hs @@ -1,20 +1,12 @@ {-# LANGUAGE CPP #-} #ifndef HASKELL98 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DataKinds #-} -# endif +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} #endif ----------------------------------------------------------------------------- -- | @@ -76,12 +68,9 @@ import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.Signatures -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 -import Data.Typeable +#ifndef HASKELL98 +import GHC.Generics #endif -- --------------------------------------------------------------------------- @@ -144,6 +133,10 @@ -- * 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 @@ -196,17 +189,15 @@ {-# INLINE (<|>) #-} instance (Monoid w, Functor m, Monad m) => Monad (AccumT w m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = AccumT $ const $ return (a, mempty) - {-# INLINE return #-} -#endif m >>= k = AccumT $ \ w -> do ~(a, w') <- runAccumT m w ~(b, w'') <- runAccumT (k a) (w `mappend` w') 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) @@ -231,10 +222,6 @@ instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where liftIO = lift . liftIO {-# INLINE liftIO #-} - -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable AccumT -#endif -- | @'look'@ is an action that fetches all the previously accumulated output. look :: (Monoid w, Monad m) => AccumT w m w diff --git a/0.5/Control/Monad/Trans/Select.hs b/0.5/Control/Monad/Trans/Select.hs --- a/0.5/Control/Monad/Trans/Select.hs +++ b/0.5/Control/Monad/Trans/Select.hs @@ -1,20 +1,12 @@ {-# LANGUAGE CPP #-} # ifndef HASKELL98 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -# endif -# if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -# endif -# if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DataKinds #-} -# endif +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} #endif ----------------------------------------------------------------------------- -- | @@ -49,7 +41,6 @@ mapSelectT, -- * Monad transformation selectToContT, - selectToCont, ) where import Control.Monad.IO.Class @@ -61,10 +52,14 @@ import qualified Control.Monad.Fail as Fail import Data.Functor.Identity -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 +#if !defined(HASKELL98) import Data.Typeable #endif +#ifndef HASKELL98 +import GHC.Generics +#endif + -- | Selection monad. type Select r = SelectT r Identity @@ -85,6 +80,10 @@ -- 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 @@ -130,10 +129,6 @@ {-# INLINE (<|>) #-} instance (Monad m) => Monad (SelectT r m) where -#if !(MIN_VERSION_base(4,8,0)) - return = lift . return - {-# INLINE return #-} -#endif SelectT g >>= f = SelectT $ \ k -> do let h x = runSelectT (f x) k y <- g ((>>= k) . h) @@ -158,16 +153,6 @@ liftIO = lift . liftIO {-# INLINE liftIO #-} -#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable SelectT -#endif - -- | Convert a selection computation to a continuation-passing computation. selectToContT :: (Monad m) => SelectT r m a -> ContT r m a selectToContT (SelectT g) = ContT $ \ k -> g k >>= k -{-# INLINE selectToCont #-} - --- | Deprecated name for 'selectToContT'. -{-# DEPRECATED selectToCont "Use selectToContT instead" #-} -selectToCont :: (Monad m) => SelectT r m a -> ContT r m a -selectToCont = selectToContT diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,41 @@ +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`, diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ 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. diff --git a/generics/Data/Functor/Classes/Generic.hs b/generics/Data/Functor/Classes/Generic.hs --- a/generics/Data/Functor/Classes/Generic.hs +++ b/generics/Data/Functor/Classes/Generic.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - {-| Module: Data.Functor.Classes.Generic Copyright: (C) 2015-2016 Edward Kmett, Ryan Scott @@ -16,21 +14,7 @@ Options(..) , defaultOptions , latestGHCOptions -#if defined(TRANSFORMERS_FOUR) -- * 'Eq1' - , eq1Default - , eq1Options - -- * 'Ord1' - , compare1Default - , compare1Options - -- * 'Read1' - , readsPrec1Default - , readsPrec1Options - -- * 'Show1' - , showsPrec1Default - , showsPrec1Options -#else - -- * 'Eq1' , liftEqDefault , liftEqOptions -- * 'Ord1' @@ -42,7 +26,6 @@ -- * 'Show1' , liftShowsPrecDefault , liftShowsPrecOptions -#endif -- * 'GenericFunctorClasses' , FunctorClassesDefault(..) -- * Example @@ -52,7 +35,6 @@ import qualified Data.Functor.Classes as C () import Data.Functor.Classes.Generic.Internal -#undef MIN_VERSION_transformers {- $example The most straightforward way to use the defaults in this module is to use @DerivingVia@ on GHC 8.6 or later. For example: @@ -71,12 +53,10 @@ @ If using an older version of GHC, then one can also define instances manually. -This is slightly trickier to accomplish since this module exports different -functions depending on which version of @transformers@ this library is built -against. Here is an example of how to define instances manually: +Here is an example: @ -{-# LANGUAGE CPP, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} import Data.Functor.Classes import Data.Functor.Classes.Generic @@ -85,31 +65,15 @@ data Pair a = Pair a a deriving Generic1 instance 'C.Eq1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.eq1' = 'eq1Default' -\#else 'C.liftEq' = 'liftEqDefault' -\#endif instance 'C.Ord1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.compare1' = 'compare1Default' -\#else 'C.liftCompare' = 'liftCompareDefault' -\#endif instance 'C.Read1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.readsPrec1' = 'readsPrec1Default' -\#else 'C.liftReadsPrec' = 'liftReadsPrecDefault' -\#endif instance 'C.Show1' Pair where -\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) - 'C.showsPrec1' = 'showsPrec1Default' -\#else 'C.liftShowsPrec' = 'liftShowsPrecDefault' -\#endif @ -} diff --git a/generics/Data/Functor/Classes/Generic/Internal.hs b/generics/Data/Functor/Classes/Generic/Internal.hs --- a/generics/Data/Functor/Classes/Generic/Internal.hs +++ b/generics/Data/Functor/Classes/Generic/Internal.hs @@ -1,934 +1,1056 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -#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' -#if defined(TRANSFORMERS_FOUR) - , eq1Default - , eq1Options -#else - , liftEqDefault - , liftEqOptions -#endif - , GEq1(..) - , Eq1Args(..) - -- * 'Ord1' -#if defined(TRANSFORMERS_FOUR) - , compare1Default - , compare1Options -#else - , liftCompareDefault - , liftCompareOptions -#endif - , GOrd1(..) - , Ord1Args(..) - -- * 'Read1' -#if defined(TRANSFORMERS_FOUR) - , readsPrec1Default - , readsPrec1Options -#else - , liftReadsPrecDefault - , liftReadsPrecOptions -#endif - , GRead1(..) - , GRead1Con(..) - , Read1Args(..) - -- * 'Show1' -#if defined(TRANSFORMERS_FOUR) - , showsPrec1Default - , showsPrec1Options -#else - , liftShowsPrecDefault - , liftShowsPrecOptions -#endif - , GShow1(..) - , GShow1Con(..) - , Show1Args(..) - -- * 'FunctorClassesDefault' - , FunctorClassesDefault(..) - -- * Miscellaneous types - , V4 - , NonV4 - , ConType(..) - , IsNullaryDataType(..) - , IsNullaryCon(..) - ) where - -import Data.Char (isSymbol, ord) -import Data.Functor.Classes -#ifdef GENERIC_DERIVING -import Generics.Deriving.Base hiding (prec) -#else -import GHC.Generics hiding (prec) -#endif -import GHC.Read (paren, parens) -import GHC.Show (appPrec, appPrec1, showSpace) -import Text.ParserCombinators.ReadPrec -import Text.Read (Read(..)) -import Text.Read.Lex (Lexeme(..)) - -#if !defined(TRANSFORMERS_FOUR) -import GHC.Read (list) -import Text.Show (showListWith) -#endif - -#if MIN_VERSION_base(4,7,0) -import GHC.Read (expectP) -#else -import GHC.Read (lexP) -import Unsafe.Coerce (unsafeCoerce) -#endif - -#if MIN_VERSION_base(4,7,0) || defined(GENERIC_DERIVING) -import GHC.Exts -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -------------------------------------------------------------------------------- --- * Options -------------------------------------------------------------------------------- - --- | Options that further configure how the functions in --- "Data.Functor.Classes.Generic" should behave. -newtype Options = Options - { ghc8ShowBehavior :: Bool - -- ^ If 'True', a default 'Show1' implementation will show hash signs - -- (@#@) when showing unlifted types. - } - --- | Options that match the behavior of the installed version of GHC. -defaultOptions :: Options -defaultOptions = Options - { -#if __GLASGOW_HASKELL__ >= 800 - ghc8ShowBehavior = True -#else - ghc8ShowBehavior = False -#endif - } - --- | Options that match the behavior of the most recent GHC release. -latestGHCOptions :: Options -latestGHCOptions = Options { ghc8ShowBehavior = True } - --- | A type-level indicator that the @transformers-0.4@ version of a class method --- is being derived generically. -data V4 - --- | A type-level indicator that the non-@transformers-0.4@ version of a class --- method is being derived generically. -data NonV4 - -------------------------------------------------------------------------------- --- * Eq1 -------------------------------------------------------------------------------- - --- | An 'Eq1Args' value either stores an @Eq a@ dictionary (for the --- @transformers-0.4@ version of 'Eq1'), or it stores the function argument that --- checks the equality of occurrences of the type parameter (for the --- non-@transformers-0.4@ version of 'Eq1'). -data Eq1Args v a b where - V4Eq1Args :: Eq a => Eq1Args V4 a a - NonV4Eq1Args :: (a -> b -> Bool) -> Eq1Args NonV4 a b - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'eq1' implementation for 'Generic1' instances. -eq1Default :: (GEq1 V4 (Rep1 f), Generic1 f, Eq a) - => f a -> f a -> Bool -eq1Default = eq1Options defaultOptions - --- | Like 'eq1Default', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -eq1Options :: (GEq1 V4 (Rep1 f), Generic1 f, Eq a) - => Options -> f a -> f a -> Bool -eq1Options _ m n = gliftEq V4Eq1Args (from1 m) (from1 n) -#else --- | A sensible default 'liftEq' implementation for 'Generic1' instances. -liftEqDefault :: (GEq1 NonV4 (Rep1 f), Generic1 f) - => (a -> b -> Bool) -> f a -> f b -> Bool -liftEqDefault = liftEqOptions defaultOptions - --- | Like 'liftEqDefault', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -liftEqOptions :: (GEq1 NonV4 (Rep1 f), Generic1 f) - => Options -> (a -> b -> Bool) -> f a -> f b -> Bool -liftEqOptions _ f m n = gliftEq (NonV4Eq1Args f) (from1 m) (from1 n) -#endif - --- | Class of generic representation types that can be checked for equality. -class GEq1 v t where - gliftEq :: Eq1Args v a b -> t a -> t b -> Bool - -instance Eq c => GEq1 v (K1 i c) where - gliftEq _ (K1 c) (K1 d) = c == d - -instance (GEq1 v f, GEq1 v g) => GEq1 v (f :*: g) where - gliftEq f (a :*: b) (c :*: d) = gliftEq f a c && gliftEq f b d - -instance (GEq1 v f, GEq1 v g) => GEq1 v (f :+: g) where - gliftEq f (L1 a) (L1 c) = gliftEq f a c - gliftEq f (R1 b) (R1 d) = gliftEq f b d - gliftEq _ _ _ = False - -instance GEq1 v f => GEq1 v (M1 i c f) where - gliftEq f (M1 a) (M1 b) = gliftEq f a b - -instance GEq1 v U1 where - gliftEq _ U1 U1 = True - -instance GEq1 v V1 where - gliftEq _ _ _ = True - -#if defined(TRANSFORMERS_FOUR) -instance GEq1 V4 Par1 where - gliftEq V4Eq1Args (Par1 a) (Par1 b) = a == b - -instance Eq1 f => GEq1 V4 (Rec1 f) where - gliftEq V4Eq1Args (Rec1 a) (Rec1 b) = eq1 a b - -instance (Functor f, Eq1 f, GEq1 V4 g) => GEq1 V4 (f :.: g) where - gliftEq V4Eq1Args (Comp1 m) (Comp1 n) = eq1 (fmap Apply m) (fmap Apply n) -#else -instance GEq1 NonV4 Par1 where - gliftEq (NonV4Eq1Args f) (Par1 a) (Par1 b) = f a b - -instance Eq1 f => GEq1 NonV4 (Rec1 f) where - gliftEq (NonV4Eq1Args f) (Rec1 a) (Rec1 b) = liftEq f a b - -instance (Eq1 f, GEq1 NonV4 g) => GEq1 NonV4 (f :.: g) where - gliftEq (NonV4Eq1Args f) (Comp1 m) (Comp1 n) = - liftEq (gliftEq (NonV4Eq1Args f)) m n -#endif - -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) --- Unboxed types -instance GEq1 v UAddr where - gliftEq _ (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2) - -instance GEq1 v UChar where - gliftEq _ (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2) - -instance GEq1 v UDouble where - gliftEq _ (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2) - -instance GEq1 v UFloat where - gliftEq _ (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2) - -instance GEq1 v UInt where - gliftEq _ (UInt i1) (UInt i2) = isTrue# (i1 ==# i2) - -instance GEq1 v UWord where - gliftEq _ (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) -#endif - -------------------------------------------------------------------------------- --- * Ord1 -------------------------------------------------------------------------------- - --- | An 'Ord1Args' value either stores an @Ord a@ dictionary (for the --- @transformers-0.4@ version of 'Ord1'), or it stores the function argument that --- compares occurrences of the type parameter (for the non-@transformers-0.4@ --- version of 'Ord1'). -data Ord1Args v a b where - V4Ord1Args :: Ord a => Ord1Args V4 a a - NonV4Ord1Args :: (a -> b -> Ordering) -> Ord1Args NonV4 a b - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'compare1' implementation for 'Generic1' instances. -compare1Default :: (GOrd1 V4 (Rep1 f), Generic1 f, Ord a) - => f a -> f a -> Ordering -compare1Default = compare1Options defaultOptions - --- | Like 'compare1Default', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -compare1Options :: (GOrd1 V4 (Rep1 f), Generic1 f, Ord a) - => Options -> f a -> f a -> Ordering -compare1Options _ m n = gliftCompare V4Ord1Args (from1 m) (from1 n) -#else --- | A sensible default 'liftCompare' implementation for 'Generic1' instances. -liftCompareDefault :: (GOrd1 NonV4 (Rep1 f), Generic1 f) - => (a -> b -> Ordering) -> f a -> f b -> Ordering -liftCompareDefault = liftCompareOptions defaultOptions - --- | Like 'liftCompareDefault', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -liftCompareOptions :: (GOrd1 NonV4 (Rep1 f), Generic1 f) - => Options -> (a -> b -> Ordering) -> f a -> f b -> Ordering -liftCompareOptions _ f m n = gliftCompare (NonV4Ord1Args f) (from1 m) (from1 n) -#endif - --- | Class of generic representation types that can be totally ordered. -class GEq1 v t => GOrd1 v t where - gliftCompare :: Ord1Args v a b -> t a -> t b -> Ordering - -instance Ord c => GOrd1 v (K1 i c) where - gliftCompare _ (K1 c) (K1 d) = compare c d - -instance (GOrd1 v f, GOrd1 v g) => GOrd1 v (f :*: g) where - gliftCompare f (a :*: b) (c :*: d) = - gliftCompare f a c `mappend` gliftCompare f b d - -instance (GOrd1 v f, GOrd1 v g) => GOrd1 v (f :+: g) where - gliftCompare f (L1 a) (L1 c) = gliftCompare f a c - gliftCompare _ L1{} R1{} = LT - gliftCompare _ R1{} L1{} = GT - gliftCompare f (R1 b) (R1 d) = gliftCompare f b d - -instance GOrd1 v f => GOrd1 v (M1 i c f) where - gliftCompare f (M1 a) (M1 b) = gliftCompare f a b - -instance GOrd1 v U1 where - gliftCompare _ U1 U1 = EQ - -instance GOrd1 v V1 where - gliftCompare _ _ _ = EQ - -#if defined(TRANSFORMERS_FOUR) -instance GOrd1 V4 Par1 where - gliftCompare V4Ord1Args (Par1 a) (Par1 b) = compare a b - -instance Ord1 f => GOrd1 V4 (Rec1 f) where - gliftCompare V4Ord1Args (Rec1 a) (Rec1 b) = compare1 a b - -instance (Functor f, Ord1 f, GOrd1 V4 g) => GOrd1 V4 (f :.: g) where - gliftCompare V4Ord1Args (Comp1 m) (Comp1 n) = - compare1 (fmap Apply m) (fmap Apply n) -#else -instance GOrd1 NonV4 Par1 where - gliftCompare (NonV4Ord1Args f) (Par1 a) (Par1 b) = f a b - -instance Ord1 f => GOrd1 NonV4 (Rec1 f) where - gliftCompare (NonV4Ord1Args f) (Rec1 a) (Rec1 b) = liftCompare f a b - -instance (Ord1 f, GOrd1 NonV4 g) => GOrd1 NonV4 (f :.: g) where - gliftCompare (NonV4Ord1Args f) (Comp1 m) (Comp1 n) = - liftCompare (gliftCompare (NonV4Ord1Args f)) m n -#endif - -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) --- Unboxed types -instance GOrd1 v UAddr where - gliftCompare _ (UAddr a1) (UAddr a2) = primCompare (eqAddr# a1 a2) (leAddr# a1 a2) - -instance GOrd1 v UChar where - gliftCompare _ (UChar c1) (UChar c2) = primCompare (eqChar# c1 c2) (leChar# c1 c2) - -instance GOrd1 v UDouble where - gliftCompare _ (UDouble d1) (UDouble d2) = primCompare (d1 ==## d2) (d1 <=## d2) - -instance GOrd1 v UFloat where - gliftCompare _ (UFloat f1) (UFloat f2) = primCompare (eqFloat# f1 f2) (leFloat# f1 f2) - -instance GOrd1 v UInt where - gliftCompare _ (UInt i1) (UInt i2) = primCompare (i1 ==# i2) (i1 <=# i2) - -instance GOrd1 v UWord where - gliftCompare _ (UWord w1) (UWord w2) = primCompare (eqWord# w1 w2) (leWord# w1 w2) - -# if __GLASGOW_HASKELL__ >= 708 -primCompare :: Int# -> Int# -> Ordering -# else -primCompare :: Bool -> Bool -> Ordering -# endif -primCompare eq le = if isTrue# eq then EQ - else if isTrue# le then LT - else GT -#endif - -------------------------------------------------------------------------------- --- * Read1 -------------------------------------------------------------------------------- - --- | A 'Read1Args' value either stores a @Read a@ dictionary (for the --- @transformers-0.4@ version of 'Read1'), or it stores the two function arguments --- that parse occurrences of the type parameter (for the non-@transformers-0.4@ --- version of 'Read1'). -data Read1Args v a where - V4Read1Args :: Read a => Read1Args V4 a - NonV4Read1Args :: ReadPrec a -> ReadPrec [a] -> Read1Args NonV4 a - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'readsPrec1' implementation for 'Generic1' instances. -readsPrec1Default :: (GRead1 V4 (Rep1 f), Generic1 f, Read a) - => Int -> ReadS (f a) -readsPrec1Default = readsPrec1Options defaultOptions - --- | Like 'readsPrec1Default', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -readsPrec1Options :: (GRead1 V4 (Rep1 f), Generic1 f, Read a) - => Options -> Int -> ReadS (f a) -readsPrec1Options _ p = - readPrec_to_S (fmap to1 $ gliftReadPrec V4Read1Args) p -#else --- | A sensible default 'liftReadsPrec' implementation for 'Generic1' instances. -liftReadsPrecDefault :: (GRead1 NonV4 (Rep1 f), Generic1 f) - => (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) -liftReadsPrecDefault = liftReadsPrecOptions defaultOptions - --- | Like 'liftReadsPrecDefault', but with configurable 'Options'. Currently, --- the 'Options' have no effect (but this may change in the future). -liftReadsPrecOptions :: (GRead1 NonV4 (Rep1 f), Generic1 f) - => Options -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) -liftReadsPrecOptions _ rp rl p = - readPrec_to_S (fmap to1 $ gliftReadPrec - (NonV4Read1Args (readS_to_Prec rp) - (readS_to_Prec (const rl)))) p -#endif - -#if !(MIN_VERSION_base(4,7,0)) -coerce :: a -> b -coerce = unsafeCoerce - -expectP :: Lexeme -> ReadPrec () -expectP lexeme = do - thing <- lexP - if thing == lexeme then return () else pfail -#endif - -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 - -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 that can be parsed from a 'String'. -class GRead1 v f where - gliftReadPrec :: Read1Args v a -> ReadPrec (f a) - -instance (GRead1 v f, IsNullaryDataType f) => GRead1 v (D1 d f) where - gliftReadPrec = coerceM1 . parensIfNonNullary . gliftReadPrec - where - x :: f p - x = undefined - - parensIfNonNullary :: ReadPrec a -> ReadPrec a - parensIfNonNullary = if isNullaryDataType x - then id - else parens - -instance GRead1 v V1 where - gliftReadPrec _ = pfail - -instance (GRead1 v f, GRead1 v g) => GRead1 v (f :+: g) where - gliftReadPrec ras = - fmap L1 (gliftReadPrec ras) +++ fmap R1 (gliftReadPrec ras) - -instance (Constructor c, GRead1Con v f, IsNullaryCon f) => GRead1 v (C1 c f) where - gliftReadPrec ras = 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 (gliftReadPrecCon t ras) - Infix _ m -> prec m $ gliftReadPrecCon t ras - 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 that can be parsed from a 'String', and --- for which the 'ConType' has been determined. -class GRead1Con v f where - gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec (f a) - -instance GRead1Con v U1 where - gliftReadPrecCon _ _ = return U1 - -instance Read c => GRead1Con v (K1 i c) where - gliftReadPrecCon _ _ = coerceK1 readPrec - where - coerceK1 :: ReadPrec c -> ReadPrec (K1 i c p) - coerceK1 = coerce - -instance (Selector s, GRead1Con v f) => GRead1Con v (S1 s f) where - gliftReadPrecCon t ras - | selectorName == "" = coerceM1 $ step $ gliftReadPrecCon t ras - | otherwise = coerceM1 $ do - mapM_ expectP $ readLblLexemes selectorName - expectP (Punc "=") - reset $ gliftReadPrecCon t ras - 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 v f, GRead1Con v g) => GRead1Con v (f :*: g) where - gliftReadPrecCon t ras = do - l <- gliftReadPrecCon t ras - case t of - Rec -> expectP (Punc ",") - Inf o -> infixPrec o - Tup -> expectP (Punc ",") - Pref -> return () - r <- gliftReadPrecCon t ras - return (l :*: r) - where - infixPrec :: String -> ReadPrec () - infixPrec o = if isInfixDataCon o - then expectP (Symbol o) - else mapM_ expectP $ - [Punc "`"] ++ identHLexemes o ++ [Punc "`"] - -#if defined(TRANSFORMERS_FOUR) -instance GRead1Con V4 Par1 where - gliftReadPrecCon _ V4Read1Args = coercePar1 readPrec - -instance Read1 f => GRead1Con V4 (Rec1 f) where - gliftReadPrecCon _ V4Read1Args = coerceRec1 $ readS_to_Prec readsPrec1 - -instance (Functor f, Read1 f, GRead1Con V4 g) => GRead1Con V4 (f :.: g) where - gliftReadPrecCon _ (V4Read1Args :: Read1Args V4 a) = - coerceComp1 $ fmap (fmap getApply) $ readS_to_Prec crp1 - where - crp1 :: Int -> ReadS (f (Apply g a)) - crp1 = readsPrec1 -#else -instance GRead1Con NonV4 Par1 where - gliftReadPrecCon _ (NonV4Read1Args rp _) = coercePar1 rp - -instance Read1 f => GRead1Con NonV4 (Rec1 f) where - gliftReadPrecCon _ (NonV4Read1Args rp rl) = coerceRec1 $ readS_to_Prec $ - liftReadsPrec (readPrec_to_S rp) (readPrec_to_S rl 0) - -instance (Read1 f, GRead1Con NonV4 g) => GRead1Con NonV4 (f :.: g) where - gliftReadPrecCon t (NonV4Read1Args rp rl) = coerceComp1 $ readS_to_Prec $ - liftReadsPrec (readPrec_to_S grpc) - (readPrec_to_S (list grpc) 0) - where - grpc = gliftReadPrecCon t (NonV4Read1Args rp rl) -#endif - -------------------------------------------------------------------------------- --- * Show1 -------------------------------------------------------------------------------- - --- | A 'Show1Args' value either stores a @Show a@ dictionary (for the --- @transformers-0.4@ version of 'Show1'), or it stores the two function arguments --- that show occurrences of the type parameter (for the non-@transformers-0.4@ --- version of 'Show1'). -data Show1Args v a where - V4Show1Args :: Show a => Show1Args V4 a - NonV4Show1Args :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Show1Args NonV4 a - -#if defined(TRANSFORMERS_FOUR) --- | A sensible default 'showsPrec1' implementation for 'Generic1' instances. -showsPrec1Default :: (GShow1 V4 (Rep1 f), Generic1 f, Show a) - => Int -> f a -> ShowS -showsPrec1Default = showsPrec1Options defaultOptions - --- | Like 'showsPrec1Default', but with configurable 'Options'. -showsPrec1Options :: (GShow1 V4 (Rep1 f), Generic1 f, Show a) - => Options -> Int -> f a -> ShowS -showsPrec1Options opts p = gliftShowsPrec opts V4Show1Args p . from1 -#else --- | A sensible default 'liftShowsPrec' implementation for 'Generic1' instances. -liftShowsPrecDefault :: (GShow1 NonV4 (Rep1 f), Generic1 f) - => (Int -> a -> ShowS) -> ([a] -> ShowS) - -> Int -> f a -> ShowS -liftShowsPrecDefault = liftShowsPrecOptions defaultOptions - --- | Like 'liftShowsPrecDefault', but with configurable 'Options'. -liftShowsPrecOptions :: (GShow1 NonV4 (Rep1 f), Generic1 f) - => Options -> (Int -> a -> ShowS) -> ([a] -> ShowS) - -> Int -> f a -> ShowS -liftShowsPrecOptions opts sp sl p = gliftShowsPrec opts (NonV4Show1Args sp sl) p . from1 -#endif - --- | Class of generic representation types that can be converted to a 'String'. -class GShow1 v f where - gliftShowsPrec :: Options -> Show1Args v a -> Int -> f a -> ShowS - -instance GShow1 v f => GShow1 v (D1 d f) where - gliftShowsPrec opts sas p (M1 x) = gliftShowsPrec opts sas p x - -instance GShow1 v V1 where -#if __GLASGOW_HASKELL__ >= 708 - gliftShowsPrec _ _ _ x = case x of {} -#else - gliftShowsPrec _ _ _ !_ = undefined -#endif - -instance (GShow1 v f, GShow1 v g) => GShow1 v (f :+: g) where - gliftShowsPrec opts sas p (L1 x) = gliftShowsPrec opts sas p x - gliftShowsPrec opts sas p (R1 x) = gliftShowsPrec opts sas p x - -instance (Constructor c, GShow1Con v f, IsNullaryCon f) => GShow1 v (C1 c f) where - gliftShowsPrec opts sas 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 (gliftShowsPrecCon opts t sas appPrec1 x) - Infix _ m -> showParen (p > m) $ gliftShowsPrecCon opts t sas (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 that can be converted to a 'String', and --- for which the 'ConType' has been determined. -class GShow1Con v f where - gliftShowsPrecCon :: Options -> ConType -> Show1Args v a - -> Int -> f a -> ShowS - -instance GShow1Con v U1 where - gliftShowsPrecCon _ _ _ _ U1 = id - -instance Show c => GShow1Con v (K1 i c) where - gliftShowsPrecCon _ _ _ p (K1 x) = showsPrec p x - -instance (Selector s, GShow1Con v f) => GShow1Con v (S1 s f) where - gliftShowsPrecCon opts t sas p sel@(M1 x) - | selName sel == "" = gliftShowsPrecCon opts t sas p x - | otherwise = infixRec - . showString " = " - . gliftShowsPrecCon opts t sas 0 x - where - infixRec :: ShowS - infixRec | isSymVar selectorName - = showChar '(' . showString selectorName . showChar ')' - | otherwise - = showString selectorName - - selectorName :: String - selectorName = selName sel - -instance (GShow1Con v f, GShow1Con v g) => GShow1Con v (f :*: g) where - gliftShowsPrecCon opts t sas p (a :*: b) = - case t of - Rec -> gliftShowsPrecCon opts t sas 0 a - . showString ", " - . gliftShowsPrecCon opts t sas 0 b - - Inf o -> gliftShowsPrecCon opts t sas p a - . showSpace - . infixOp o - . showSpace - . gliftShowsPrecCon opts t sas p b - - Tup -> gliftShowsPrecCon opts t sas 0 a - . showChar ',' - . gliftShowsPrecCon opts t sas 0 b - - Pref -> gliftShowsPrecCon opts t sas p a - . showSpace - . gliftShowsPrecCon opts t sas p b - where - infixOp :: String -> ShowS - infixOp o = if isInfixDataCon o - then showString o - else showChar '`' . showString o . showChar '`' - -#if defined(TRANSFORMERS_FOUR) -instance GShow1Con V4 Par1 where - gliftShowsPrecCon _ _ V4Show1Args p (Par1 x) = showsPrec p x - -instance Show1 f => GShow1Con V4 (Rec1 f) where - gliftShowsPrecCon _ _ V4Show1Args p (Rec1 x) = showsPrec1 p x - -instance (Functor f, Show1 f, GShow1Con V4 g) => GShow1Con V4 (f :.: g) where - gliftShowsPrecCon _ _ V4Show1Args p (Comp1 x) = showsPrec1 p (fmap Apply x) -#else -instance GShow1Con NonV4 Par1 where - gliftShowsPrecCon _ _ (NonV4Show1Args sp _) p (Par1 x) = sp p x - -instance Show1 f => GShow1Con NonV4 (Rec1 f) where - gliftShowsPrecCon _ _ (NonV4Show1Args sp sl) p (Rec1 x) = liftShowsPrec sp sl p x - -instance (Show1 f, GShow1Con NonV4 g) => GShow1Con NonV4 (f :.: g) where - gliftShowsPrecCon opts t (NonV4Show1Args sp sl) p (Comp1 x) = - let glspc = gliftShowsPrecCon opts t (NonV4Show1Args sp sl) - in liftShowsPrec glspc (showListWith (glspc 0)) p x -#endif - -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -instance GShow1Con v UChar where - gliftShowsPrecCon opts _ _ p (UChar c) = - showsPrec (hashPrec opts p) (C# c) . oneHash opts - -instance GShow1Con v UDouble where - gliftShowsPrecCon opts _ _ p (UDouble d) = - showsPrec (hashPrec opts p) (D# d) . twoHash opts - -instance GShow1Con v UFloat where - gliftShowsPrecCon opts _ _ p (UFloat f) = - showsPrec (hashPrec opts p) (F# f) . oneHash opts - -instance GShow1Con v UInt where - gliftShowsPrecCon opts _ _ p (UInt i) = - showsPrec (hashPrec opts p) (I# i) . oneHash opts - -instance GShow1Con v UWord where - gliftShowsPrecCon opts _ _ p (UWord w) = - showsPrec (hashPrec opts p) (W# w) . twoHash opts - -oneHash, twoHash :: Options -> ShowS -hashPrec :: Options -> Int -> Int -oneHash opts = if ghc8ShowBehavior opts then showChar '#' else id -twoHash opts = if ghc8ShowBehavior opts then showString "##" else id -hashPrec opts = if ghc8ShowBehavior opts then const 0 else id -#endif - -------------------------------------------------------------------------------- --- * 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 } - -#if defined(TRANSFORMERS_FOUR) -instance (GEq1 V4 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where - eq1 (FunctorClassesDefault x) (FunctorClassesDefault y) = eq1Default x y -instance (GOrd1 V4 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where - compare1 (FunctorClassesDefault x) (FunctorClassesDefault y) = compare1Default x y -instance (GRead1 V4 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where - readsPrec1 p = coerceFCD (readsPrec1Default p) -instance (GShow1 V4 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where - showsPrec1 p (FunctorClassesDefault x) = showsPrec1Default p x -#else -instance (GEq1 NonV4 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where - liftEq f (FunctorClassesDefault x) (FunctorClassesDefault y) = liftEqDefault f x y -instance (GOrd1 NonV4 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where - liftCompare f (FunctorClassesDefault x) (FunctorClassesDefault y) = liftCompareDefault f x y -instance (GRead1 NonV4 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where - liftReadsPrec rp rl p = coerceFCD (liftReadsPrecDefault rp rl p) -instance (GShow1 NonV4 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where - liftShowsPrec sp sl p (FunctorClassesDefault x) = liftShowsPrecDefault sp sl p x -#endif - -coerceFCD :: ReadS (f a) -> ReadS (FunctorClassesDefault f a) -coerceFCD = coerce - -------------------------------------------------------------------------------- --- * Shared code -------------------------------------------------------------------------------- - -#if defined(TRANSFORMERS_FOUR) -newtype Apply g a = Apply { getApply :: g a } - -instance (GEq1 V4 g, Eq a) => Eq (Apply g a) where - Apply x == Apply y = gliftEq V4Eq1Args x y - -instance (GOrd1 V4 g, Ord a) => Ord (Apply g a) where - compare (Apply x) (Apply y) = gliftCompare V4Ord1Args x y - --- Passing defaultOptions and Pref below is OK, since it's guaranteed that the --- Options and ConType won't actually have any effect on how (g a) is shown. --- If we augment Options or ConType with more features in the future, this --- decision will need to be revisited. - -instance (GRead1Con V4 g, Read a) => Read (Apply g a) where - readPrec = fmap Apply $ gliftReadPrecCon Pref V4Read1Args - -instance (GShow1Con V4 g, Show a) => Show (Apply g a) where - showsPrec d = gliftShowsPrecCon defaultOptions Pref V4Show1Args d . getApply -#endif - --- | 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 - -#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -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 - -# if __GLASGOW_HASKELL__ < 708 -isTrue# :: Bool -> Bool -isTrue# = id -# endif -#endif +{-# 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,28 +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 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 @@ -52,10 +44,8 @@ import Control.Monad.Trans.Accum (AccumT(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Cont (ContT(..)) -import Control.Monad.Trans.Error (Error(..), ErrorT(..)) import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Identity (IdentityT(..)) -import Control.Monad.Trans.List (ListT(..), mapListT) 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(..)) @@ -77,29 +67,22 @@ 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(..)) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy(..)) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Bifunctor (Bifunctor(..)) -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Semigroup as Semigroup (Semigroup(..)) +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error (Error(..), ErrorT(..)) +import Control.Monad.Trans.List (ListT(..), mapListT) #endif #if MIN_VERSION_base(4,10,0) @@ -110,461 +93,10 @@ #ifndef HASKELL98 import Data.Data (Data) import Data.Typeable - -# ifdef GENERIC_DERIVING -import Generics.Deriving.Base -# elif __GLASGOW_HASKELL__ >= 702 import GHC.Generics -# endif #endif -#if !(MIN_VERSION_transformers(0,3,0)) --- Foldable/Traversable instances -instance (Foldable f) => Foldable (ErrorT e f) where - foldMap f (ErrorT a) = foldMap (either (const mempty) f) a - -instance (Traversable f) => Traversable (ErrorT e f) where - traverse f (ErrorT a) = - ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a - -instance (Foldable f) => Foldable (IdentityT f) where - foldMap f (IdentityT a) = foldMap f a - -instance (Traversable f) => Traversable (IdentityT f) where - traverse f (IdentityT a) = IdentityT <$> traverse f a - -instance (Foldable f) => Foldable (ListT f) where - foldMap f (ListT a) = foldMap (foldMap f) a - -instance (Traversable f) => Traversable (ListT f) where - traverse f (ListT a) = ListT <$> traverse (traverse f) a - -instance (Foldable f) => Foldable (MaybeT f) where - foldMap f (MaybeT a) = foldMap (foldMap f) a - -instance (Traversable f) => Traversable (MaybeT f) where - traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a - -instance (Foldable f) => Foldable (Lazy.WriterT w f) where - foldMap f = foldMap (f . fst) . Lazy.runWriterT - -instance (Traversable f) => Traversable (Lazy.WriterT w f) where - traverse f = fmap Lazy.WriterT . traverse f' . Lazy.runWriterT where - f' (a, b) = fmap (\ c -> (c, b)) (f a) - -instance (Foldable f) => Foldable (Strict.WriterT w f) where - foldMap f = foldMap (f . fst) . Strict.runWriterT - -instance (Traversable f) => Traversable (Strict.WriterT w f) where - traverse f = fmap Strict.WriterT . traverse f' . Strict.runWriterT where - f' (a, b) = fmap (\ c -> (c, b)) (f a) - --- MonadFix instances for IdentityT and MaybeT -instance (MonadFix m) => MonadFix (IdentityT m) where - mfix f = IdentityT (mfix (runIdentityT . f)) - -instance (MonadFix m) => MonadFix (MaybeT m) where - mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb)) - where bomb = error "mfix (MaybeT): inner computation returned Nothing" - -# if !(MIN_VERSION_base(4,9,0)) --- Monad instances for Product -instance (Monad f, Monad g) => Monad (Product f g) where - return x = Pair (return x) (return x) - Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) - where - fstP (Pair a _) = a - sndP (Pair _ b) = b - -instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where - mzero = Pair mzero mzero - Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) - -instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where - mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) - where - fstP (Pair a _) = a - sndP (Pair _ b) = b -# endif -#endif - -#if !(MIN_VERSION_transformers(0,4,0)) --- Alternative IO instance -# if !(MIN_VERSION_base(4,9,0)) --- The version bounds of transformers prior to 0.4.0.0 should prevent this --- instance from being compiled on base-4.8.0.0 and later, but we'll put --- a check here just to be safe. -instance Alternative IO where - empty = mzero - (<|>) = mplus -# endif -#endif - -#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,4,3)) --- transformers-0.4-specific Eq1, Ord1, Read1, and Show1 instances for Const -instance (Eq a) => Eq1 (Const a) where - eq1 (Const x) (Const y) = x == y -instance (Ord a) => Ord1 (Const a) where - compare1 (Const x) (Const y) = compare x y -instance (Read a) => Read1 (Const a) where - readsPrec1 = readsData $ readsUnary "Const" Const -instance (Show a) => Show1 (Const a) where - showsPrec1 d (Const x) = showsUnary "Const" d x -#endif - -#if !(MIN_VERSION_transformers(0,5,0)) \ - || (MIN_VERSION_transformers(0,5,0) && !(MIN_VERSION_base(4,9,0))) --- MonadFail instances -instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where - fail msg = ContT $ \ _ -> Fail.fail msg - {-# INLINE fail #-} - -instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where - fail msg = ErrorT $ return (Left (strMsg msg)) - -instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where - fail msg = IdentityT $ Fail.fail msg - {-# INLINE fail #-} - -instance (Monad m) => Fail.MonadFail (ListT m) where - fail _ = ListT $ return [] - {-# INLINE fail #-} - -instance (Monad m) => Fail.MonadFail (MaybeT m) where - fail _ = MaybeT (return Nothing) - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where - fail msg = lift (Fail.fail msg) - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.RWST r w s m) where - fail msg = Lazy.RWST $ \ _ _ -> Fail.fail msg - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.RWST r w s m) where - fail msg = Strict.RWST $ \ _ _ -> Fail.fail msg - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (Lazy.StateT s m) where - fail str = Lazy.StateT $ \ _ -> Fail.fail str - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (Strict.StateT s m) where - fail str = Strict.StateT $ \ _ -> Fail.fail str - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.WriterT w m) where - fail msg = Lazy.WriterT $ Fail.fail msg - {-# INLINE fail #-} - -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.WriterT w m) where - fail msg = Strict.WriterT $ Fail.fail msg - {-# INLINE fail #-} - -# if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_base(4,9,0)) -instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where - fail = ExceptT . Fail.fail - {-# INLINE fail #-} -# endif - -# if MIN_VERSION_transformers(0,5,3) && !(MIN_VERSION_base(4,9,0)) -instance (Monoid w, Functor m, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where - fail msg = AccumT $ const (Fail.fail msg) - {-# INLINE fail #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where - fail msg = lift (Fail.fail msg) - {-# INLINE fail #-} -# endif -#endif - -#if !(MIN_VERSION_transformers(0,5,0)) --- Monoid Constant instance -instance (Monoid a) => Monoid (Constant a b) where - mempty = Constant mempty - Constant x `mappend` Constant y = Constant (x `mappend` y) - --- MonadZip instances -# if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (IdentityT m) where - mzipWith f (IdentityT a) (IdentityT b) = IdentityT (mzipWith f a b) - -instance (MonadZip m) => MonadZip (ListT m) where - mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b - -instance (MonadZip m) => MonadZip (MaybeT m) where - mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b - -instance (MonadZip m) => MonadZip (ReaderT r m) where - mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a -> - mzipWith f (m a) (n a) - -instance (Monoid w, MonadZip m) => MonadZip (Lazy.WriterT w m) where - mzipWith f (Lazy.WriterT x) (Lazy.WriterT y) = Lazy.WriterT $ - mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y - -instance (Monoid w, MonadZip m) => MonadZip (Strict.WriterT w m) where - mzipWith f (Strict.WriterT x) (Strict.WriterT y) = Strict.WriterT $ - mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y - -# if !(MIN_VERSION_base(4,8,0)) -instance MonadZip Identity where - mzipWith f (Identity x) (Identity y) = Identity (f x y) - munzip (Identity (a, b)) = (Identity a, Identity b) -# endif - -# if !(MIN_VERSION_base(4,9,0)) -instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where - mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) -# endif -# endif - -# if MIN_VERSION_base(4,8,0) --- Bifunctor Constant instance -instance Bifunctor Constant where - first f (Constant x) = Constant (f x) - second _ (Constant x) = Constant x -# else --- Monoid Identity instance -instance (Monoid a) => Monoid (Identity a) where - mempty = Identity mempty - mappend (Identity x) (Identity y) = Identity (mappend x y) -# endif - -# ifndef HASKELL98 --- Typeable instances -# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -deriving instance Typeable Backwards -deriving instance Typeable Constant -deriving instance Typeable ContT -deriving instance Typeable ErrorT -deriving instance Typeable IdentityT -deriving instance Typeable Lift -deriving instance Typeable ListT -deriving instance Typeable MaybeT -deriving instance Typeable MonadTrans -deriving instance Typeable Lazy.RWST -deriving instance Typeable Strict.RWST -deriving instance Typeable ReaderT -deriving instance Typeable Reverse -deriving instance Typeable Lazy.StateT -deriving instance Typeable Strict.StateT - -# if !(MIN_VERSION_base(4,9,0)) -deriving instance Typeable Compose -deriving instance Typeable MonadIO -deriving instance Typeable Product -# endif -# endif - --- Identity instances -# if !(MIN_VERSION_base(4,8,0)) -deriving instance Typeable1 Identity -deriving instance Data a => Data (Identity a) -# if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable 'Identity -# endif -# endif - -# if !(MIN_VERSION_base(4,9,0)) -# if __GLASGOW_HASKELL__ >= 708 --- Data instances for Compose and Product -deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) - => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) -deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) - => Data (Product (f :: * -> *) (g :: * -> *) (a :: *)) - -# if MIN_VERSION_transformers(0,4,0) --- Typeable/Data instances for Sum --- These are also present in Data.Functor.Sum in transformers-compat, but only --- these are reachable if using @transformers-0.4.0.0@ -deriving instance Typeable Sum -deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) - => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) -# endif -# endif -# endif -# endif -#endif - -#if !(MIN_VERSION_transformers(0,5,1)) -# if !(MIN_VERSION_base(4,8,0)) -instance (Bounded a) => Bounded (Identity a) where - minBound = Identity minBound - maxBound = Identity maxBound - -instance (Enum a) => Enum (Identity a) where - succ (Identity x) = Identity (succ x) - pred (Identity x) = Identity (pred x) - toEnum i = Identity (toEnum i) - fromEnum (Identity x) = fromEnum x - enumFrom (Identity x) = map Identity (enumFrom x) - enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y) - enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y) - enumFromThenTo (Identity x) (Identity y) (Identity z) = - map Identity (enumFromThenTo x y z) - -instance (Ix a) => Ix (Identity a) where - range (Identity x, Identity y) = map Identity (range (x, y)) - index (Identity x, Identity y) (Identity i) = index (x, y) i - inRange (Identity x, Identity y) (Identity e) = inRange (x, y) e - rangeSize (Identity x, Identity y) = rangeSize (x, y) - -instance (Storable a) => Storable (Identity a) where - sizeOf (Identity x) = sizeOf x - alignment (Identity x) = alignment x - peekElemOff p i = fmap Identity (peekElemOff (castPtr p) i) - pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x - peekByteOff p i = fmap Identity (peekByteOff p i) - pokeByteOff p i (Identity x) = pokeByteOff p i x - peek p = fmap runIdentity (peek (castPtr p)) - poke p (Identity x) = poke (castPtr p) x -# endif -#endif - #if !(MIN_VERSION_transformers(0,5,3)) -# if !(MIN_VERSION_base(4,9,0)) -# if MIN_VERSION_base(4,7,0) --- Data.Proxy -# if defined(TRANSFORMERS_FOUR) -instance Eq1 Proxy where - eq1 _ _ = True - -instance Ord1 Proxy where - compare1 _ _ = EQ - -instance Show1 Proxy where - showsPrec1 _ _ = showString "Proxy" - -instance Read1 Proxy where - readsPrec1 d = - readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) -# elif MIN_VERSION_transformers(0,5,0) -instance Eq1 Proxy where - liftEq _ _ _ = True - -instance Ord1 Proxy where - liftCompare _ _ _ = EQ - -instance Show1 Proxy where - liftShowsPrec _ _ _ _ = showString "Proxy" - -instance Read1 Proxy where - liftReadsPrec _ _ d = - readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) -# endif -# endif -# endif - -# if !(MIN_VERSION_base(4,8,0)) --- Data.Functor.Identity -instance (Bits a) => Bits (Identity a) where - Identity x .&. Identity y = Identity (x .&. y) - Identity x .|. Identity y = Identity (x .|. y) - xor (Identity x) (Identity y) = Identity (xor x y) - complement (Identity x) = Identity (complement x) - shift (Identity x) i = Identity (shift x i) - rotate (Identity x) i = Identity (rotate x i) - setBit (Identity x) i = Identity (setBit x i) - clearBit (Identity x) i = Identity (clearBit x i) - shiftL (Identity x) i = Identity (shiftL x i) - shiftR (Identity x) i = Identity (shiftR x i) - rotateL (Identity x) i = Identity (rotateL x i) - rotateR (Identity x) i = Identity (rotateR x i) - testBit (Identity x) i = testBit x i - bitSize (Identity x) = bitSize x - isSigned (Identity x) = isSigned x - bit i = Identity (bit i) -# if MIN_VERSION_base(4,5,0) - unsafeShiftL (Identity x) i = Identity (unsafeShiftL x i) - unsafeShiftR (Identity x) i = Identity (unsafeShiftR x i) - popCount (Identity x) = popCount x -# endif -# if MIN_VERSION_base(4,7,0) - zeroBits = Identity zeroBits - bitSizeMaybe (Identity x) = bitSizeMaybe x -# endif - -# if MIN_VERSION_base(4,7,0) -instance (FiniteBits a) => FiniteBits (Identity a) where - finiteBitSize (Identity x) = finiteBitSize x -# endif - -instance (Floating a) => Floating (Identity a) where - pi = Identity pi - exp (Identity x) = Identity (exp x) - log (Identity x) = Identity (log x) - sqrt (Identity x) = Identity (sqrt x) - sin (Identity x) = Identity (sin x) - cos (Identity x) = Identity (cos x) - tan (Identity x) = Identity (tan x) - asin (Identity x) = Identity (asin x) - acos (Identity x) = Identity (acos x) - atan (Identity x) = Identity (atan x) - sinh (Identity x) = Identity (sinh x) - cosh (Identity x) = Identity (cosh x) - tanh (Identity x) = Identity (tanh x) - asinh (Identity x) = Identity (asinh x) - acosh (Identity x) = Identity (acosh x) - atanh (Identity x) = Identity (atanh x) - Identity x ** Identity y = Identity (x ** y) - logBase (Identity x) (Identity y) = Identity (logBase x y) - -instance (Fractional a) => Fractional (Identity a) where - Identity x / Identity y = Identity (x / y) - recip (Identity x) = Identity (recip x) - fromRational r = Identity (fromRational r) - -instance (IsString a) => IsString (Identity a) where - fromString s = Identity (fromString s) - -instance (Integral a) => Integral (Identity a) where - quot (Identity x) (Identity y) = Identity (quot x y) - rem (Identity x) (Identity y) = Identity (rem x y) - div (Identity x) (Identity y) = Identity (div x y) - mod (Identity x) (Identity y) = Identity (mod x y) - quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y) - divMod (Identity x) (Identity y) = (Identity *** Identity) (divMod x y) - toInteger (Identity x) = toInteger x - -instance (Num a) => Num (Identity a) where - Identity x + Identity y = Identity (x + y) - Identity x - Identity y = Identity (x - y) - Identity x * Identity y = Identity (x * y) - negate (Identity x) = Identity (negate x) - abs (Identity x) = Identity (abs x) - signum (Identity x) = Identity (signum x) - fromInteger n = Identity (fromInteger n) - -instance (Real a) => Real (Identity a) where - toRational (Identity x) = toRational x - -instance (RealFloat a) => RealFloat (Identity a) where - floatRadix (Identity x) = floatRadix x - floatDigits (Identity x) = floatDigits x - floatRange (Identity x) = floatRange x - decodeFloat (Identity x) = decodeFloat x - exponent (Identity x) = exponent x - isNaN (Identity x) = isNaN x - isInfinite (Identity x) = isInfinite x - isDenormalized (Identity x) = isDenormalized x - isNegativeZero (Identity x) = isNegativeZero x - isIEEE (Identity x) = isIEEE x - significand (Identity x) = significand (Identity x) - scaleFloat s (Identity x) = Identity (scaleFloat s x) - encodeFloat m n = Identity (encodeFloat m n) - atan2 (Identity x) (Identity y) = Identity (atan2 x y) - -instance (RealFrac a) => RealFrac (Identity a) where - properFraction (Identity x) = (id *** Identity) (properFraction x) - truncate (Identity x) = truncate x - round (Identity x) = round x - ceiling (Identity x) = ceiling x - floor (Identity x) = floor x -# endif - -# if MIN_VERSION_transformers(0,3,0) -- Data.Functor.Reverse instance (Monad m) => Monad (Reverse m) where return a = Reverse (return a) @@ -583,7 +115,6 @@ {-# INLINE mzero #-} Reverse x `mplus` Reverse y = Reverse (x `mplus` y) {-# INLINE mplus #-} -# endif #endif #if !(MIN_VERSION_transformers(0,5,4)) @@ -599,154 +130,72 @@ #endif #if !(MIN_VERSION_transformers(0,5,5)) -# if MIN_VERSION_base(4,9,0) instance (Semigroup.Semigroup a) => Semigroup.Semigroup (Constant a b) where Constant x <> Constant y = Constant (x Semigroup.<> y) {-# INLINE (<>) #-} -# endif +# if !(MIN_VERSION_transformers(0,6,0)) instance (MonadFix m) => MonadFix (ListT m) where mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of [] -> return [] x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f))) {-# INLINE mfix #-} +# endif #endif -- Generic(1) instances #ifndef HASKELL98 -# if (!(MIN_VERSION_transformers(0,5,0)) && (__GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING))) \ - || (MIN_VERSION_transformers(0,5,0) && __GLASGOW_HASKELL__ < 702 && defined(GENERIC_DERIVING)) - -# if !(MIN_VERSION_base(4,8,0)) -instance Generic (Identity a) where - type Rep (Identity a) = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity (Rec0 a))) - from (Identity x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Identity x - -instance Generic1 Identity where - type Rep1 Identity = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity Par1)) - from1 (Identity x) = M1 (M1 (M1 (Par1 x))) - to1 (M1 (M1 (M1 x))) = Identity (unPar1 x) - -data MDIdentity -data MCIdentity -data MSIdentity - -instance Datatype MDIdentity where - datatypeName _ = "Identity" - moduleName _ = "Data.Functor.Identity" -# if __GLASGOW_HASKELL__ >= 708 - isNewtype _ = True -# endif - -instance Constructor MCIdentity where - conName _ = "Identity" - conIsRecord _ = True - -instance Selector MSIdentity where - selName _ = "runIdentity" -# endif - -# if !(MIN_VERSION_base(4,9,0)) --- Generic(1) instances for Compose -instance Generic (Compose f g a) where - type Rep (Compose f g a) = - D1 MDCompose - (C1 MCCompose - (S1 MSCompose (Rec0 (f (g a))))) - from (Compose x) = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = Compose x - -instance Functor f => Generic1 (Compose f g) where - type Rep1 (Compose f g) = - D1 MDCompose - (C1 MCCompose - (S1 MSCompose (f :.: Rec1 g))) - from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x)))) - to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x)) - -data MDCompose -data MCCompose -data MSCompose - -instance Datatype MDCompose where - datatypeName _ = "Compose" - moduleName _ = "Data.Functor.Compose" -# if __GLASGOW_HASKELL__ >= 708 - isNewtype _ = True -# endif +# 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) -instance Constructor MCCompose where - conName _ = "Compose" - conIsRecord _ = True +deriving instance Generic (Constant a b) +deriving instance Generic1 (Constant a) -instance Selector MSCompose where - selName _ = "getCompose" +deriving instance Generic (ContT r 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 (IdentityT f a) +deriving instance Generic1 (IdentityT f) -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 (MaybeT m a) +deriving instance Functor m => Generic1 (MaybeT m) -data MDProduct -data MCPair +deriving instance Generic (Lazy.RWST r w s m a) +deriving instance Generic (Strict.RWST r w s m a) -instance Datatype MDProduct where - datatypeName _ = "Product" - moduleName _ = "Data.Functor.Product" +deriving instance Generic (ReaderT r m a) +deriving instance Generic1 (ReaderT r m) -instance Constructor MCPair where - conName _ = "Pair" +deriving instance Generic (Lazy.StateT s m a) +deriving instance Generic (Strict.StateT s m a) -# if MIN_VERSION_transformers(0,4,0) --- Generic(1) instances for Sum --- These are also present in Data.Functor.Sum in transformers-compat, but only --- these are reachable if using @transformers-0.4.0.0@ or later -instance Generic (Sum f g a) where - type Rep (Sum f g a) = - D1 MDSum (C1 MCInL (S1 NoSelector (Rec0 (f a))) - :+: C1 MCInR (S1 NoSelector (Rec0 (g a)))) - from (InL f) = M1 (L1 (M1 (M1 (K1 f)))) - from (InR g) = M1 (R1 (M1 (M1 (K1 g)))) - to (M1 (L1 (M1 (M1 (K1 f))))) = InL f - to (M1 (R1 (M1 (M1 (K1 g))))) = InR g +deriving instance Generic (Lazy.WriterT w m a) +deriving instance Generic (Strict.WriterT w m 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) +deriving instance Generic (Backwards f a) +deriving instance Generic1 (Backwards f) -data MDSum -data MCInL -data MCInR +deriving instance Generic (Lift f a) +deriving instance Generic1 (Lift f) -instance Datatype MDSum where - datatypeName _ = "Sum" - moduleName _ = "Data.Functor.Sum" +deriving instance Generic (Reverse f a) +deriving instance Generic1 (Reverse f) -instance Constructor MCInL where - conName _ = "InL" +deriving instance Generic (ExceptT e m a) +deriving instance Functor m => Generic1 (ExceptT e m) -instance Constructor MCInR where - conName _ = "InR" +# 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 --- a/tests/GenericsSpec.hs +++ b/tests/GenericsSpec.hs @@ -16,21 +16,21 @@ main :: IO () main = hspec spec -prop_Eq :: (Eq a, Eq (f a), Eq1 f) => f a -> f a -> Bool -prop_Eq x y = (x == y) == eq1 x y +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 -> Bool) +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 -> Bool -prop_Ord x y = compare x y == compare1 x y +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 -> Bool) +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 @@ -45,8 +45,8 @@ prop_Read :: forall f a. (Read a, Read (f a), Read1 f, Eq (f a), Show (f a)) - => f a -> Bool -prop_Read x = readArb readsPrec == readArb readsPrec1 + => f a -> Expectation +prop_Read x = readArb readsPrec `shouldBe` readArb readsPrec1 where readArb :: (Int -> ReadS (f a)) -> f a readArb = read' (show x) @@ -54,14 +54,14 @@ 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 -> Bool) +readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Expectation) -prop_Show :: (Show a, Show (f a), Show1 f) => Int -> f a -> Bool -prop_Show p x = showsPrec p x "" == showsPrec1 p x "" +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 -> Bool) +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, diff --git a/tests/GenericsTypes.hs b/tests/GenericsTypes.hs --- a/tests/GenericsTypes.hs +++ b/tests/GenericsTypes.hs @@ -1,27 +1,18 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -#endif module GenericsTypes where -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif - import Data.Functor.Classes import Data.Functor.Classes.Generic -#if __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) -#endif import GHC.Exts import Test.QuickCheck (Arbitrary(..), oneof) @@ -115,10 +106,7 @@ instance Arbitrary (Empty a) where arbitrary = return $ error "Arbitrary Empty" -#if __GLASGOW_HASKELL__ == 700 --- Workaround for GHC Trac #5041 -$(deriveRead ''T#) -#elif __GLASGOW_HASKELL__ == 804 +#if __GLASGOW_HASKELL__ == 804 -- Workaround for GHC Trac #14918 $(deriveRead ''T#) #else @@ -139,44 +127,21 @@ $(deriveAll1 ''Empty) #endif -#if __GLASGOW_HASKELL__ >= 706 deriving instance Generic1 TestParam deriving instance Generic1 T# deriving instance Generic1 Infix deriving instance Generic1 GADT deriving instance Generic1 Record -#else -$(deriveAll1 ''TestParam) -$(deriveAll1 ''T#) -$(deriveAll1 ''Infix) -$(deriveAll1 ''GADT) -$(deriveAll1 ''Record) -#endif -#if __GLASGOW_HASKELL__ >= 800 deriving instance Generic1 Prim -#else -$(deriveAll1 ''Prim) -#endif #define CLASS1_INSTANCE(class,type,method,impl) \ instance class type where { method = impl }; \ -#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) -# define TRANSFORMERS_FOUR 1 -#endif - -#if defined(TRANSFORMERS_FOUR) -# define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,eq1,eq1Default) -# define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,compare1,compare1Default) -# define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,readsPrec1,readsPrec1Default) -# define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,showsPrec1,showsPrec1Default) -#else -# define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,liftEq,liftEqDefault) -# define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,liftCompare,liftCompareDefault) -# define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,liftReadsPrec,liftReadsPrecDefault) -# define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,liftShowsPrec,liftShowsPrecDefault) -#endif +#define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,liftEq,liftEqDefault) +#define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,liftCompare,liftCompareDefault) +#define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,liftReadsPrec,liftReadsPrecDefault) +#define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,liftShowsPrec,liftShowsPrecDefault) #define CLASS1_INSTANCES(type) \ EQ1_INSTANCE(type) \ diff --git a/tests/transformers-compat-tests.cabal b/tests/transformers-compat-tests.cabal --- a/tests/transformers-compat-tests.cabal +++ b/tests/transformers-compat-tests.cabal @@ -7,28 +7,30 @@ author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional -homepage: http://github.com/ekmett/transformers-compat/ -bug-reports: http://github.com/ekmett/transformers-compat/issues +homepage: https://github.com/ekmett/transformers-compat/ +bug-reports: https://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: transformers-compat tests description: @transformers-copmat@ tests build-type: Simple -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , 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: git://github.com/ekmett/transformers-compat.git + location: https://github.com/ekmett/transformers-compat.git flag tests default: True @@ -42,14 +44,14 @@ main-is: Spec.hs other-modules: GenericsSpec GenericsTypes - build-depends: base >= 4.3 && < 5 - , deriving-compat >= 0.4 && < 1 - , generic-deriving >= 1.10 && < 2 - , hspec >= 2 && < 3 - , QuickCheck >= 2 && < 3 - , tagged >= 0.7 && < 1 - , transformers >= 0.2 && < 0.6 + build-depends: base >= 4.3 && < 5 + , hspec >= 2 && < 3 + , QuickCheck >= 2 && < 3 , transformers-compat + if !impl(ghc >= 8.4) + build-depends: generic-deriving >= 1.10 && < 2 + if !impl(ghc >= 8.6) + build-depends: deriving-compat >= 0.4 && < 1 build-tool-depends: hspec-discover:hspec-discover >= 2 && < 3 hs-source-dirs: . ghc-options: -Wall -threaded -rtsopts diff --git a/transformers-compat.cabal b/transformers-compat.cabal --- a/transformers-compat.cabal +++ b/transformers-compat.cabal @@ -1,42 +1,42 @@ name: transformers-compat category: Compatibility -version: 0.6.6 +version: 0.8 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional -homepage: http://github.com/ekmett/transformers-compat/ -bug-reports: http://github.com/ekmett/transformers-compat/issues +homepage: https://github.com/ekmett/transformers-compat/ +bug-reports: https://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: A small compatibility shim for the transformers library description: - This package includes backported versions of types that were added - to transformers in transformers 0.3, 0.4, and 0.5 for users who need strict - transformers 0.2 or 0.3 compatibility to run on old versions of the - platform, but also need those types. + This package includes backported versions of types that were added to + @transformers@ in @transformers-0.5@ for users who need strict + @transformers-0.5@ compatibility, but also need those types. . - Those users should be able to just depend on @transformers >= 0.2@ - and @transformers-compat >= 0.3@. + Those users should be able to just depend on @transformers >= 0.5@ and + @transformers-compat >= 0.7.3@. . Note: missing methods are not supplied, but this at least permits the types to be used. build-type: Simple -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , 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 @@ -50,22 +50,7 @@ source-repository head type: git - location: git://github.com/ekmett/transformers-compat.git - -flag two - default: False - description: Use transformers 0.2. This will be selected by cabal picking the appropriate version. - manual: False - -flag three - default: False - manual: False - description: Use transformers 0.3. This will be selected by cabal picking the appropriate version. - -flag four - default: False - manual: False - description: Use transformers 0.4. This will be selected by cabal picking the appropriate version. + location: https://github.com/ekmett/transformers-compat.git flag five default: False @@ -73,7 +58,7 @@ description: Use transformers 0.5 up until (but not including) 0.5.3. This will be selected by cabal picking the appropriate version. flag five-three - default: False + default: True manual: False description: Use transformers 0.5.3. This will be selected by cabal picking the appropriate version. @@ -93,13 +78,11 @@ library build-depends: - base >= 4.3 && < 5, + base >= 4.9 && < 5, -- These are all transformers versions we support. -- each flag below splits this interval into two parts. -- flag-true parts are mutually exclusive, so at least one have to be on. - transformers >= 0.2 && <0.6 - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* + transformers >= 0.5 && <0.7 hs-source-dirs: src @@ -123,68 +106,22 @@ hs-source-dirs: 0.5 build-depends: transformers >= 0.5 && < 0.5.3 else - build-depends: transformers < 0.5 || >= 0.5.3 - - if flag(four) - cpp-options: -DTRANSFORMERS_FOUR - hs-source-dirs: 0.5 - -- Don't allow transformers-0.4.0.0 - -- See https://github.com/ekmett/transformers-compat/issues/35 - build-depends: transformers >= 0.4.1 && < 0.5 - else - build-depends: transformers < 0.4 || >= 0.5 - - if flag(three) - hs-source-dirs: 0.3 0.5 - build-depends: transformers >= 0.3 && < 0.4 - if flag(mtl) - build-depends: mtl >= 2.1 && < 2.2 - else - build-depends: transformers < 0.3 || >= 0.4 - - if flag(two) - hs-source-dirs: 0.2 0.3 0.5 - build-depends: transformers >= 0.2 && < 0.3 - if flag(mtl) - build-depends: mtl >= 2.0 && < 2.1 - else - build-depends: transformers >= 0.3 + build-depends: transformers >= 0.5.3 -- other flags - if impl(ghc >= 7.2) || flag(generic-deriving) + if impl(ghc) && flag(generic-deriving) hs-source-dirs: generics - build-depends: ghc-prim + exposed-modules: + Data.Functor.Classes.Generic + Data.Functor.Classes.Generic.Internal if flag(mtl) cpp-options: -DMTL - if flag(generic-deriving) - if impl(ghc < 8.0) && flag(generic-deriving) - cpp-options: -DGENERIC_DERIVING - build-depends: generic-deriving >= 1.10 && < 2 - if !flag(mtl) && !flag(generic-deriving) cpp-options: -DHASKELL98 - if flag(two) - exposed-modules: - Control.Applicative.Backwards - Control.Applicative.Lift - Data.Functor.Reverse - - if flag(two) || flag(three) - exposed-modules: - Control.Monad.Trans.Except - Control.Monad.Signatures - Data.Functor.Classes - Data.Functor.Sum - - if flag(two) || flag(three) || flag(four) || flag(five) + if flag(five) exposed-modules: Control.Monad.Trans.Accum Control.Monad.Trans.Select - - if impl(ghc >= 7.2) || flag(generic-deriving) - exposed-modules: - Data.Functor.Classes.Generic - Data.Functor.Classes.Generic.Internal