transformers-compat 0.5.1.4 → 0.6.0.2
raw patch · 19 files changed
+2659/−77 lines, 19 filesdep +QuickCheckdep +deriving-compatdep +generic-derivingdep ~transformersnew-uploader
Dependencies added: QuickCheck, deriving-compat, generic-deriving, hspec, tagged, transformers-compat
Dependency ranges changed: transformers
Files
- .gitignore +23/−0
- .travis.yml +246/−19
- 0.2/Control/Applicative/Backwards.hs +17/−1
- 0.2/Control/Applicative/Lift.hs +31/−1
- 0.2/Data/Functor/Reverse.hs +37/−1
- 0.3/Control/Monad/Signatures.hs +3/−1
- 0.3/Control/Monad/Trans/Except.hs +34/−3
- 0.3/Data/Functor/Classes.hs +18/−0
- 0.3/Data/Functor/Sum.hs +19/−9
- 0.5/Control/Monad/Trans/Accum.hs +309/−0
- 0.5/Control/Monad/Trans/Select.hs +177/−0
- CHANGELOG.markdown +101/−2
- generics/Data/Functor/Classes/Generic.hs +96/−0
- generics/Data/Functor/Classes/Generic/Internal.hs +875/−0
- src/Control/Monad/Trans/Instances.hs +314/−21
- tests/GenericsSpec.hs +94/−0
- tests/GenericsTypes.hs +164/−0
- tests/Spec.hs +1/−0
- transformers-compat.cabal +100/−19
.gitignore view
@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -7,3 +8,25 @@ .DS_Store .*.swp .*.swo+*.o+*.hi+*~+*#+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*
.travis.yml view
@@ -1,21 +1,14 @@-language: haskell-before_install:- # Uncomment whenever hackage is down.- # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update-- # Try installing some of the build-deps with apt-get for speed.- - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode-- - sudo apt-get -q -y install hlint || cabal install hlint--install:- - cabal configure $mode- - cabal build+# This Travis job script has been generated by a script via+#+# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project'+#+# For more information, see https://github.com/hvr/multi-ghc-travis+#+language: c+sudo: false -script:- - $script- - hlint 0.2 --cpp-define HLINT- - hlint 0.3 --cpp-define HLINT+git:+ submodules: false # whether to recursively clone submodules notifications: irc:@@ -25,5 +18,239 @@ template: - "\x0313transformers-compat\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" -env:- - mode="--enable-tests" script="cabal test"+cache:+ directories:+ - $HOME/.cabal/packages+ - $HOME/.cabal/store++before_cache:+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+ # remove files that are regenerated by 'cabal update'+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx++ - rm -rfv $HOME/.cabal/packages/head.hackage++addons:+ apt:+ packages: &apt_packages+ - ghc-ppa-tools++matrix:+ include:+ - compiler: "ghc-7.0.4"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-f-generic-deriving"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-f-generic-deriving -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ftwo"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ftwo -f-generic-deriving"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ftwo -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ftwo -f-generic-deriving -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-fthree"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-fthree -f-generic-deriving"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-fthree -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-fthree -f-generic-deriving -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffour"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffour -f-generic-deriving"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffour -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffour -f-generic-deriving -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffive"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffive -f-generic-deriving"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffive -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.0.4"+ env: CABALFLAGS="-ffive -f-generic-deriving -f-mtl"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.2.2"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.2.2"+ env: CABALFLAGS="-ftwo"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.2.2"+ env: CABALFLAGS="-fthree"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.2.2"+ env: CABALFLAGS="-ffour"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.2.2"+ env: CABALFLAGS="-ffive"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.4.2"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.4.2"+ env: CABALFLAGS="-ftwo"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.4.2"+ env: CABALFLAGS="-fthree"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.4.2"+ env: CABALFLAGS="-ffour"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.4.2"+ env: CABALFLAGS="-ffive"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.6.3"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.6.3"+ env: CABALFLAGS="-ftwo"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.6.3"+ env: CABALFLAGS="-fthree"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.6.3"+ env: CABALFLAGS="-ffour"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.6.3"+ env: CABALFLAGS="-ffive"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.8.4"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.8.4"+ env: CABALFLAGS="-ftwo"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.8.4"+ env: CABALFLAGS="-fthree"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.8.4"+ env: CABALFLAGS="-ffour"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.8.4"+ env: CABALFLAGS="-ffive"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.10.3"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.10.3"+ env: CABALFLAGS="-ffour"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.10.3"+ env: CABALFLAGS="-ffive"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}+ - compiler: "ghc-8.0.2"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}+ - compiler: "ghc-8.0.2"+ env: CABALFLAGS="-ffive"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}+ - compiler: "ghc-8.2.2"+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-8.4.1"+ env: GHCHEAD=true+ addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}+ - compiler: "ghc-head"+ env: GHCHEAD=true+ addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}}++ allow_failures:+ - compiler: "ghc-8.4.1"+ - compiler: "ghc-head"++before_install:+ - HC=${CC}+ - HCPKG=${HC/ghc/ghc-pkg}+ - unset CC+ - ROOTDIR=$(pwd)+ - mkdir -p $HOME/.local/bin+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))+ - echo $HCNUMVER++install:+ - cabal --version+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - BENCH=${BENCH---enable-benchmarks}+ - TEST=${TEST---disable-tests} # https://github.com/ekmett/transformers-compat/issues/24+ - HADDOCK=${HADDOCK-true}+ - INSTALLED=${INSTALLED-true}+ - GHCHEAD=${GHCHEAD-false}+ - travis_retry cabal update -v+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"+ - rm -fv cabal.project cabal.project.local+ # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage+ - |+ if $GHCHEAD; then+ sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config++ echo 'repository head.hackage' >> ${HOME}/.cabal/config+ echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config+ echo ' secure: True' >> ${HOME}/.cabal/config+ echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config+ echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config+ echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config+ echo ' key-threshold: 3' >> ${HOME}/.cabal.config++ cabal new-update head.hackage -v+ fi+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+ - "printf 'packages: \".\"\\n' > cabal.project"+ - cat cabal.project+ - if [ -f "./configure.ac" ]; then+ (cd "." && autoreconf -i);+ fi+ - rm -f cabal.project.freeze+ - cabal new-build -w ${HC} ${CABALFLAGS} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all+ - rm -rf "."/.ghc.environment.* "."/dist+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)++# Here starts the actual work to be performed for the package under test;+# any command which exits with a non-zero exit code causes the build to fail.+script:+ # test that source-distributions can be generated+ - (cd "." && cabal sdist)+ - mv "."/dist/transformers-compat-*.tar.gz ${DISTDIR}/+ - cd ${DISTDIR} || false+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;+ - "printf 'packages: transformers-compat-*/*.cabal\\n' > cabal.project"+ - cat cabal.project+++ # build & run tests, build benchmarks+ - cabal new-build -w ${HC} ${CABALFLAGS} ${TEST} ${BENCH} all+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${CABALFLAGS} ${TEST} ${BENCH} all; fi++ # cabal check+ - (cd transformers-compat-* && cabal check)++ # haddock+ - rm -rf ./dist-newstyle+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${CABALFLAGS} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi++# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"]+# EOF
0.2/Control/Applicative/Backwards.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} #ifndef HASKELL98-# if __GLASGOW_HASKELL__ >= 702+# if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}+# elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}@@ -37,9 +39,11 @@ 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 $@@ -57,26 +61,38 @@ -- | 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 #-}
0.2/Control/Applicative/Lift.hs view
@@ -26,10 +26,12 @@ Lift(..), unLift, mapLift,+ elimLift, -- * Collecting errors Errors, runErrors,- failure+ failure,+ eitherToErrors ) where import Data.Functor.Classes@@ -49,12 +51,14 @@ 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 $@@ -74,40 +78,60 @@ 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",@@ -132,7 +156,13 @@ runErrors :: Errors e a -> Either e a runErrors (Other (Constant e)) = Left e runErrors (Pure x) = Right x+{-# INLINE runErrors #-} -- | Report an error. failure :: e -> Errors e a failure e = Other (Constant e)+{-# INLINE failure #-}++-- | Convert from 'Either' to 'Errors' (inverse of 'runErrors').+eitherToErrors :: Either e a -> Errors e a+eitherToErrors = either failure Pure
0.2/Data/Functor/Reverse.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} #ifndef HASKELL98-# if __GLASGOW_HASKELL__ >= 702+# if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}+# elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}@@ -30,6 +32,10 @@ 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@@ -40,9 +46,11 @@ 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 $@@ -60,28 +68,56 @@ -- | 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 #-}
0.3/Control/Monad/Signatures.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} #ifndef HASKELL98-# if __GLASGOW_HASKELL__ >= 702+# if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}+# elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}
0.3/Control/Monad/Trans/Except.hs view
@@ -8,7 +8,7 @@ #define MIN_VERSION_mtl(x,y,z) 1 #endif -#ifndef HASKELL98+#ifdef MTL {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}@@ -70,7 +70,7 @@ import Control.Monad.Zip (MonadZip(mzipWith)) #endif -#ifndef HASKELL98+#ifdef MTL import Control.Monad.Writer.Class import Control.Monad.State.Class import Control.Monad.Reader.Class@@ -97,11 +97,13 @@ -- (The inverse of 'runExcept'). except :: Either e a -> Except e a except m = ExceptT (Identity 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. --@@ -110,11 +112,13 @@ -> 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. --@@ -131,10 +135,12 @@ 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 $@@ -164,24 +170,30 @@ -> 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@@ -191,45 +203,59 @@ 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 (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@.@@ -239,6 +265,7 @@ -- * @'throwE' e >>= m = 'throwE' e@ throwE :: (Monad m) => e -> ExceptT e m a throwE = ExceptT . return . Left+{-# INLINE throwE #-} -- | Handle an exception. --@@ -255,18 +282,21 @@ 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@@ -275,10 +305,11 @@ 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. -#ifndef HASKELL98+#ifdef MTL instance Monad m => MonadError e (ExceptT e m) where throwError = throwE
0.3/Data/Functor/Classes.hs view
@@ -78,6 +78,9 @@ 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@@ -390,6 +393,21 @@ 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
0.3/Data/Functor/Sum.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE CPP #-} #ifndef HASKELL98-# if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+# if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}@@ -15,9 +18,6 @@ # if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-} # endif #endif -- |@@ -42,7 +42,9 @@ import Data.Traversable (Traversable(traverse)) #ifndef HASKELL98-# if __GLASGOW_HASKELL__ >= 702+# ifdef GENERIC_DERIVING+import Generics.Deriving.Base+# elif __GLASGOW_HASKELL__ >= 702 import GHC.Generics # endif # if __GLASGOW_HASKELL__ >= 708@@ -54,8 +56,16 @@ data Sum f g a = InL (f a) | InR (g a) #ifndef HASKELL98-# if __GLASGOW_HASKELL__ >= 702-deriving instance Generic (Sum f g a)+# 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) =
+ 0.5/Control/Monad/Trans/Accum.hs view
@@ -0,0 +1,309 @@+{-# 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+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Trans.Accum+-- Copyright : (c) Nickolay Kudasov 2016+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- The lazy 'AccumT' monad transformer, which adds accumulation+-- capabilities (such as declarations or document patches) to a given monad.+--+-- This monad transformer provides append-only accumulation+-- during the computation. For more general access, use+-- "Control.Monad.Trans.State" instead.+-----------------------------------------------------------------------------++module Control.Monad.Trans.Accum (+ -- * The Accum monad+ Accum,+ accum,+ runAccum,+ execAccum,+ evalAccum,+ mapAccum,+ -- * The AccumT monad transformer+ AccumT(AccumT),+ runAccumT,+ execAccumT,+ evalAccumT,+ mapAccumT,+ -- * Accum operations+ look,+ looks,+ add,+ -- * Lifting other operations+ liftCallCC,+ liftCallCC',+ liftCatch,+ liftListen,+ liftPass,+ -- * Monad transformations+ readerToAccumT,+ writerToAccumT,+ accumToStateT,+ ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.Writer (WriterT(..))+import Control.Monad.Trans.State (StateT(..))+import Data.Functor.Identity++import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Fix+import Control.Monad.Signatures+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif++#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++-- ---------------------------------------------------------------------------+-- | An accumulation monad parameterized by the type @w@ of output to accumulate.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+type Accum w = AccumT w Identity++-- | Construct an accumulation computation from a (result, output) pair.+-- (The inverse of 'runAccum'.)+accum :: (Monad m) => (w -> (a, w)) -> AccumT w m a+accum f = AccumT $ \ w -> return (f w)+{-# INLINE accum #-}++-- | Unwrap an accumulation computation as a (result, output) pair.+-- (The inverse of 'accum'.)+runAccum :: Accum w a -> w -> (a, w)+runAccum m = runIdentity . runAccumT m+{-# INLINE runAccum #-}++-- | Extract the output from an accumulation computation.+--+-- * @'execAccum' m w = 'snd' ('runAccum' m w)@+execAccum :: Accum w a -> w -> w+execAccum m w = snd (runAccum m w)+{-# INLINE execAccum #-}++-- | Evaluate an accumulation computation with the given initial output history+-- and return the final value, discarding the final output.+--+-- * @'evalAccum' m w = 'fst' ('runAccum' m w)@+evalAccum :: (Monoid w) => Accum w a -> w -> a+evalAccum m w = fst (runAccum m w)+{-# INLINE evalAccum #-}++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runAccum' ('mapAccum' f m) = f . 'runAccum' m@+mapAccum :: ((a, w) -> (b, w)) -> Accum w a -> Accum w b+mapAccum f = mapAccumT (Identity . f . runIdentity)+{-# INLINE mapAccum #-}++-- ---------------------------------------------------------------------------+-- | An accumulation monad parameterized by:+--+-- * @w@ - the output to accumulate.+--+-- * @m@ - The inner monad.+--+-- The 'return' function produces the output 'mempty', while @>>=@+-- combines the outputs of the subcomputations using 'mappend'.+--+-- This monad transformer is similar to both state and writer monad transformers.+-- Thus it can be seen as+--+-- * a restricted append-only version of a state monad transformer or+--+-- * a writer monad transformer with the extra ability to read all previous output.+newtype AccumT w m a = AccumT (w -> m (a, w))++-- | Unwrap an accumulation computation.+runAccumT :: AccumT w m a -> w -> m (a, w)+runAccumT (AccumT f) = f+{-# INLINE runAccumT #-}++-- | Extract the output from an accumulation computation.+--+-- * @'execAccumT' m w = 'liftM' 'snd' ('runAccumT' m w)@+execAccumT :: (Monad m) => AccumT w m a -> w -> m w+execAccumT m w = do+ ~(_, w') <- runAccumT m w+ return w'+{-# INLINE execAccumT #-}++-- | Evaluate an accumulation computation with the given initial output history+-- and return the final value, discarding the final output.+--+-- * @'evalAccumT' m w = 'liftM' 'fst' ('runAccumT' m w)@+evalAccumT :: (Monad m, Monoid w) => AccumT w m a -> w -> m a+evalAccumT m w = do+ ~(a, _) <- runAccumT m w+ return a+{-# INLINE evalAccumT #-}++-- | Map both the return value and output of a computation using+-- the given function.+--+-- * @'runAccumT' ('mapAccumT' f m) = f . 'runAccumT' m@+mapAccumT :: (m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b+mapAccumT f m = AccumT (f . runAccumT m)+{-# INLINE mapAccumT #-}++instance (Functor m) => Functor (AccumT w m) where+ fmap f = mapAccumT $ fmap $ \ ~(a, w) -> (f a, w)+ {-# INLINE fmap #-}++instance (Monoid w, Functor m, Monad m) => Applicative (AccumT w m) where+ pure a = AccumT $ const $ return (a, mempty)+ {-# INLINE pure #-}+ mf <*> mv = AccumT $ \ w -> do+ ~(f, w') <- runAccumT mf w+ ~(v, w'') <- runAccumT mv (w `mappend` w')+ return (f v, w' `mappend` w'')+ {-# INLINE (<*>) #-}++instance (Monoid w, Functor m, MonadPlus m) => Alternative (AccumT w m) where+ empty = AccumT $ const mzero+ {-# INLINE empty #-}+ m <|> n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w+ {-# INLINE (<|>) #-}++instance (Monoid w, Functor m, Monad m) => Monad (AccumT w m) where+#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 (>>=) #-}+ fail msg = AccumT $ const (fail msg)+ {-# INLINE fail #-}++#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where+ fail msg = AccumT $ const (Fail.fail msg)+ {-# INLINE fail #-}+#endif++instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where+ mzero = AccumT $ const mzero+ {-# INLINE mzero #-}+ m `mplus` n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w+ {-# INLINE mplus #-}++instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where+ mfix m = AccumT $ \ w -> mfix $ \ ~(a, _) -> runAccumT (m a) w+ {-# INLINE mfix #-}++instance (Monoid w) => MonadTrans (AccumT w) where+ lift m = AccumT $ const $ do+ a <- m+ return (a, mempty)+ {-# INLINE lift #-}++instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++#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+look = AccumT $ \ w -> return (w, mempty)++-- | @'look'@ is an action that retrieves a function of the previously accumulated output.+looks :: (Monoid w, Monad m) => (w -> a) -> AccumT w m a+looks f = AccumT $ \ w -> return (f w, mempty)++-- | @'add' w@ is an action that produces the output @w@.+add :: (Monad m) => w -> AccumT w m ()+add w = accum $ const ((), w)+{-# INLINE add #-}++-- | Uniform lifting of a @callCC@ operation to the new monad.+-- This version rolls back to the original output history on entering the+-- continuation.+liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b+liftCallCC callCC f = AccumT $ \ w ->+ callCC $ \ c ->+ runAccumT (f (\ a -> AccumT $ \ _ -> c (a, w))) w+{-# INLINE liftCallCC #-}++-- | In-situ lifting of a @callCC@ operation to the new monad.+-- This version uses the current output history on entering the continuation.+-- It does not satisfy the uniformity property (see "Control.Monad.Signatures").+liftCallCC' :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b+liftCallCC' callCC f = AccumT $ \ s ->+ callCC $ \ c ->+ runAccumT (f (\ a -> AccumT $ \ s' -> c (a, s'))) s+{-# INLINE liftCallCC' #-}++-- | Lift a @catchE@ operation to the new monad.+liftCatch :: Catch e m (a, w) -> Catch e (AccumT w m) a+liftCatch catchE m h =+ AccumT $ \ w -> runAccumT m w `catchE` \ e -> runAccumT (h e) w+{-# INLINE liftCatch #-}++-- | Lift a @listen@ operation to the new monad.+liftListen :: (Monad m) => Listen w m (a, s) -> Listen w (AccumT s m) a+liftListen listen m = AccumT $ \ s -> do+ ~((a, s'), w) <- listen (runAccumT m s)+ return ((a, w), s')+{-# INLINE liftListen #-}++-- | Lift a @pass@ operation to the new monad.+liftPass :: (Monad m) => Pass w m (a, s) -> Pass w (AccumT s m) a+liftPass pass m = AccumT $ \ s -> pass $ do+ ~((a, f), s') <- runAccumT m s+ return ((a, s'), f)+{-# INLINE liftPass #-}++-- | Convert a read-only computation into an accumulation computation.+readerToAccumT :: (Functor m, Monoid w) => ReaderT w m a -> AccumT w m a+readerToAccumT (ReaderT f) = AccumT $ \ w -> fmap (\ a -> (a, mempty)) (f w)+{-# INLINE readerToAccumT #-}++-- | Convert a writer computation into an accumulation computation.+writerToAccumT :: WriterT w m a -> AccumT w m a+writerToAccumT (WriterT m) = AccumT $ const $ m+{-# INLINE writerToAccumT #-}++-- | Convert an accumulation (append-only) computation into a fully+-- stateful computation.+accumToStateT :: (Functor m, Monoid s) => AccumT s m a -> StateT s m a+accumToStateT (AccumT f) =+ StateT $ \ w -> fmap (\ ~(a, w') -> (a, w `mappend` w')) (f w)+{-# INLINE accumToStateT #-}
+ 0.5/Control/Monad/Trans/Select.hs view
@@ -0,0 +1,177 @@+{-# 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+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Trans.Select+-- Copyright : (c) Ross Paterson 2017+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Selection monad transformer, modelling search algorithms.+--+-- * Martin Escardo and Paulo Oliva.+-- "Selection functions, bar recursion and backward induction",+-- /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168.+-- <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf>+--+-- * Jules Hedges. "Monad transformers for backtracking search".+-- In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058>+-----------------------------------------------------------------------------++module Control.Monad.Trans.Select (+ -- * The Select monad+ Select,+ select,+ runSelect,+ mapSelect,+ -- * The SelectT monad transformer+ SelectT(SelectT),+ runSelectT,+ mapSelectT,+ -- * Monad transformation+ selectToContT,+ selectToCont,+ ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont++import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Data.Functor.Identity++#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++-- | Selection monad.+type Select r = SelectT r Identity++-- | Constructor for computations in the selection monad.+select :: ((a -> r) -> a) -> Select r a+select f = SelectT $ \ k -> Identity (f (runIdentity . k))+{-# INLINE select #-}++-- | Runs a @Select@ computation with a function for evaluating answers+-- to select a particular answer. (The inverse of 'select'.)+runSelect :: Select r a -> (a -> r) -> a+runSelect m k = runIdentity (runSelectT m (Identity . k))+{-# INLINE runSelect #-}++-- | Selection monad transformer.+--+-- 'SelectT' is not a functor on the category of monads, and many operations+-- cannot be lifted through it.+newtype SelectT r m a = SelectT ((a -> m r) -> m a)++-- | Runs a @SelectT@ computation with a function for evaluating answers+-- to select a particular answer. (The inverse of 'select'.)+runSelectT :: SelectT r m a -> (a -> m r) -> m a+runSelectT (SelectT g) = g+{-# INLINE runSelectT #-}++-- | Apply a function to transform the result of a selection computation.+-- This has a more restricted type than the @map@ operations for other+-- monad transformers, because 'SelectT' does not define a functor in+-- the category of monads.+--+-- * @'runSelectT' ('mapSelectT' f m) = f . 'runSelectT' m@+mapSelectT :: (m a -> m a) -> SelectT r m a -> SelectT r m a+mapSelectT f m = SelectT $ f . runSelectT m+{-# INLINE mapSelectT #-}++-- | Apply a function to transform the result of a selection computation.+--+-- * @'runSelect' ('mapSelect' f m) = f . 'runSelect' m@+mapSelect :: (a -> a) -> Select r a -> Select r a+mapSelect f = mapSelectT (Identity . f . runIdentity)+{-# INLINE mapSelect #-}++instance (Functor m) => Functor (SelectT r m) where+ fmap f (SelectT g) = SelectT (fmap f . g . (. f))+ {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (SelectT r m) where+ pure = lift . return+ {-# INLINE pure #-}+ SelectT gf <*> SelectT gx = SelectT $ \ k -> do+ let h f = liftM f (gx (k . f))+ f <- gf ((>>= k) . h)+ h f+ {-# INLINE (<*>) #-}+ m *> k = m >>= \_ -> k+ {-# INLINE (*>) #-}++instance (Functor m, MonadPlus m) => Alternative (SelectT r m) where+ empty = mzero+ {-# INLINE empty #-}+ (<|>) = mplus+ {-# INLINE (<|>) #-}++instance (Monad m) => Monad (SelectT r m) where+#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)+ h y+ {-# INLINE (>>=) #-}++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where+ fail msg = lift (Fail.fail msg)+ {-# INLINE fail #-}+#endif++instance (MonadPlus m) => MonadPlus (SelectT r m) where+ mzero = SelectT (const mzero)+ {-# INLINE mzero #-}+ SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k+ {-# INLINE mplus #-}++instance MonadTrans (SelectT r) where+ lift = SelectT . const+ {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (SelectT r m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++#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
CHANGELOG.markdown view
@@ -1,12 +1,104 @@+0.6.0.6+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with none of `-ftwo`, `-fthree`, `-ffour`, or `-ffive` (which works with `transformers-0.5.3` and above).++0.6.0.5+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-ffive` (which works with `transformers-0.5` up until, but not including, `transformers-0.5.3`).++0.6.0.4+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-ffour` (which works with the `transformers-0.4` series).++0.6.0.3+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series).++0.6.0.2+-------+* Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series).++0.6+---+* Introduce the `Data.Functor.Classes.Generic` module, which provides functions that can generically implement methods in the `Eq1`, `Ord1`, `Read1`, and `Show1` classes (without the usual boilerplate involved).+* Introduce the `generic-deriving` flag. When enabled, `transformers-compat` will depend on the `generic-deriving` library on older versions of GHC to backport `GHC.Generics` support for `Generic` instances and the machinery in `Data.Functor.Classes.Generic`.+* Some instances were present in `Data.Functor.Sum` but not in `Control.Monad.Trans.Instances` (e.g., the `Generic`, `Typeable`, and `Data` instances for `Sum`). This has been fixed.+* Backport changes from `transformers-0.5.5`:+ * Backport the `Semigroup` instance for `Constant`+ * Add `mapSelect` and `mapSelectT`+ * Define `selectToContT` (and deprecate `selectToCont` in favor of that)+ * Define some explicit `(*>)` definitions to avoid space leaks+* Backport changes from `transformers-0.5.4` (i.e., add `Bifoldable` and `Bitraversable` instances for `Data.Functor.Constant`)+* Backport changes from `transformers-0.5.3`:+ * Backport the `Control.Monad.Trans.Accum` and `Control.Monad.Trans.Select` modules+ * Backport the `eitherToErrors` and `elimLift` functions to `Control.Applicative.Lift`+ * Backport `Bits`, `FiniteBits`, `IsString`, `Num`, `Real`, `Integral`, `Fractional`, `Floating`, `RealFrac`, and `RealFloat` instances for `Data.Functor.Identity`+ * Backport `Monad`, `MonadFail`, and `MonadPlus` instances for `Data.Functor.Reverse`+ * Backport `Eq1`, `Ord1`, `Read1`, and `Show1` instances for `Data.Proxy`+* Backport changes from `transformers-0.5.2` (i.e., add more `INLINE` annotations)+* Backport changes from `transformers-0.5.1` (i.e., add `Bounded`, `Enum`, `Ix`, and `Storable` instances for `Identity`)++0.5.1.4+-------+* Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above).++0.5.1.3+-------+* Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series).++0.5.1.2+-------+* Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series).++0.5.1+-----+* Fix a bug in which `PolyKinds` was enabled on GHC 7.4, resulting in interface file bugs on that version of GHC.++0.5.0.4+-------+* Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above).++0.5.0.3+-------+* Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series).++0.5.0.2+-------+* Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series).++0.5+---+* Update `transformers-compat` to incorporate changes from the `transformers-0.5` series. These changes include:+ * The `Data.Functor.Classes` module was completely redesigned.+ * Modules now have `Safe` or `Trustworthy` annotations.+ * Data types and type synonyms are poly-kinded when possible.+* Add `Control.Monad.Trans.Instances`, a module of orphan instances that mimic instances available in later versions of `transformers`.+ 0.4.0.4 -------+* Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above). 0.4.0.3 -------+* Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.4.0.2 --------* Each of these is a build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker.+* Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.4 ---@@ -19,14 +111,21 @@ 0.3.3.4 -------+* Versions 0.3.3.2–0.3.3.4 were a successful attempt to fix build problems caused by the cabal backtracker.+* Each of these is a build with a different set of flags configured.+ This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above). 0.3.3.3 -------+* Versions 0.3.3.2–0.3.3.4 were a successful attempt to fix build problems caused by the cabal backtracker.+* Each of these is a build with a different set of flags configured.+ This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.3.3.2 --------* These releases were a successful attempt to fix build problems caused by the cabal backtracker.+* Versions 0.3.3.2–0.3.3.4 were a successful attempt to fix build problems caused by the cabal backtracker. * Each of these is a build with a different set of flags configured.+ This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.3.2 -----
+ generics/Data/Functor/Classes/Generic.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}++{-|+Module: Data.Functor.Classes.Generic+Copyright: (C) 2015-2016 Edward Kmett, Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Stability: Provisional+Portability: GHC++Functions to generically derive 'C.Eq1', 'C.Ord1', 'C.Read1', and 'C.Show1'+instances from "Data.Functor.Classes".+-}+module Data.Functor.Classes.Generic+ ( -- * Options+ Options(..)+ , defaultOptions+ , latestGHCOptions+#if defined(TRANSFORMERS_FOUR)+ -- * 'Eq1'+ , eq1Default+ , eq1Options+ -- * 'Ord1'+ , compare1Default+ , compare1Options+ -- * 'Read1'+ , readsPrec1Default+ , readsPrec1Options+ -- * 'Show1'+ , showsPrec1Default+ , showsPrec1Options+#else+ -- * 'Eq1'+ , liftEqDefault+ , liftEqOptions+ -- * 'Ord1'+ , liftCompareDefault+ , liftCompareOptions+ -- * 'Read1'+ , liftReadsPrecDefault+ , liftReadsPrecOptions+ -- * 'Show1'+ , liftShowsPrecDefault+ , liftShowsPrecOptions+#endif+ -- * Example+ -- $example+ ) where++import qualified Data.Functor.Classes as C ()+import Data.Functor.Classes.Generic.Internal++#undef MIN_VERSION_transformers+{- $example+Note that this module exports different functions depending on which version of+@transformers@ this library is built against. Here is an example of how to+use this module correctly:++@+{-# LANGUAGE DeriveGeneric #-}++import Data.Functor.Classes+import Data.Functor.Classes.Generic+import GHC.Generics++data Pair a = Pair a a deriving Generic1++instance 'C.Eq1' Pair where+\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0))+ 'C.eq1' = 'eq1Default'+\#else+ 'C.liftEq' = 'liftEqDefault'+\#endif++instance 'C.Ord1' Pair where+\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0))+ 'C.compare1' = 'compare1Default'+\#else+ 'C.liftCompare' = 'liftCompareDefault'+\#endif++instance 'C.Read1' Pair where+\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0))+ 'C.readsPrec1' = 'readsPrec1Default'+\#else+ 'C.liftReadsPrec' = 'liftReadsPrecDefault'+\#endif++instance 'C.Show1' Pair where+\#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0))+ 'C.showsPrec1' = 'showsPrec1Default'+\#else+ 'C.liftShowsPrec' = 'liftShowsPrecDefault'+\#endif+@+-}
+ generics/Data/Functor/Classes/Generic/Internal.hs view
@@ -0,0 +1,875 @@+{-# 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 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(..)+ -- * Miscellaneous types+ , V4+ , NonV4+ , ConType(..)+ , IsNullary(..)+ ) 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 $ parens $ 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 $ parens $ 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 => GRead1 v (D1 d f) where+ gliftReadPrec = coerceM1 . gliftReadPrec++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, IsNullary 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 isNullary 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, IsNullary f) => GShow1 v (C1 c f) where+ gliftShowsPrec opts sas p c@(M1 x) = case fixity of+ Prefix -> showParen ( p > appPrec+ && not (isNullary x || conIsTuple c)+ ) $+ (if conIsTuple c+ then id+ else let cn = conName c+ in showParen (isInfixDataCon cn) (showString cn))+ . (if isNullary 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++-------------------------------------------------------------------------------+-- * 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 constructor with+-- zero or more fields.+class IsNullary f where+ -- Returns 'True' if the constructor has no fields.+ isNullary :: f a -> Bool++instance IsNullary U1 where+ isNullary _ = True++instance IsNullary Par1 where+ isNullary _ = False++instance IsNullary (K1 i c) where+ isNullary _ = False++instance IsNullary f => IsNullary (S1 s f) where+ isNullary (M1 x) = isNullary x++instance IsNullary (Rec1 f) where+ isNullary _ = False++instance IsNullary (f :*: g) where+ isNullary _ = False++instance IsNullary (f :.: g) where+ isNullary _ = False++#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)+instance IsNullary UChar where+ isNullary _ = False++instance IsNullary UDouble where+ isNullary _ = False++instance IsNullary UFloat where+ isNullary _ = False++instance IsNullary UInt where+ isNullary _ = False++instance IsNullary UWord where+ isNullary _ = False++# if __GLASGOW_HASKELL__ < 708+isTrue# :: Bool -> Bool+isTrue# = id+# endif+#endif
src/Control/Monad/Trans/Instances.hs view
@@ -10,7 +10,6 @@ {-# LANGUAGE TypeOperators #-} # if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Trustworthy #-} # endif @@ -69,29 +68,50 @@ import Data.Functor.Identity (Identity(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Reverse (Reverse(..))-import Data.Functor.Sum ()+import Data.Functor.Sum (Sum(..)) import Control.Applicative+import Control.Arrow (Arrow((***))) import Control.Monad (MonadPlus(..)) import Control.Monad.Fix (MonadFix(..))+import Data.Bits import Data.Foldable (Foldable(..))+import Data.Ix (Ix(..)) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..))+import Data.String (IsString(fromString)) import Data.Traversable (Traversable(..))+import Foreign (Storable(..), castPtr) #if MIN_VERSION_base(4,4,0) 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 Control.Monad.Fail as Fail (MonadFail(..))+import qualified Data.Semigroup as Semigroup (Semigroup(..))+#endif++#if MIN_VERSION_base(4,10,0)+import Data.Bifoldable (Bifoldable(..))+import Data.Bitraversable (Bitraversable(..))+#endif+ #ifndef HASKELL98 import Data.Data (Data) import Data.Typeable -# if __GLASGOW_HASKELL__ >= 702+# ifdef GENERIC_DERIVING+import Generics.Deriving.Base+# elif __GLASGOW_HASKELL__ >= 702 import GHC.Generics # endif #endif@@ -273,8 +293,258 @@ # 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 __GLASGOW_HASKELL__ >= 702+# if !(MIN_VERSION_base(4,9,0))+# if __GLASGOW_HASKELL__ >= 708+-- Data instances for Compose and Product+deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a)+ => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *))+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+ => Data (Product (f :: * -> *) (g :: * -> *) (a :: *))++# if MIN_VERSION_transformers(0,4,0)+-- Typeable/Data instances for Sum+-- These are also present in Data.Functor.Sum in transformers-compat, but only+-- these are reachable if using @transformers-0.4.0.0@+deriving instance Typeable Sum+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+ => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *))+# endif+# endif+# endif+# endif+#endif++#if !(MIN_VERSION_transformers(0,5,1))+# if !(MIN_VERSION_base(4,8,0))+instance (Bounded a) => Bounded (Identity a) where+ minBound = Identity minBound+ maxBound = Identity maxBound++instance (Enum a) => Enum (Identity a) where+ succ (Identity x) = Identity (succ x)+ pred (Identity x) = Identity (pred x)+ toEnum i = Identity (toEnum i)+ fromEnum (Identity x) = fromEnum x+ enumFrom (Identity x) = map Identity (enumFrom x)+ enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y)+ enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y)+ enumFromThenTo (Identity x) (Identity y) (Identity z) =+ map Identity (enumFromThenTo x y z)++instance (Ix a) => Ix (Identity a) where+ range (Identity x, Identity y) = map Identity (range (x, y))+ index (Identity x, Identity y) (Identity i) = index (x, y) i+ inRange (Identity x, Identity y) (Identity e) = inRange (x, y) e+ rangeSize (Identity x, Identity y) = rangeSize (x, y)++instance (Storable a) => Storable (Identity a) where+ sizeOf (Identity x) = sizeOf x+ alignment (Identity x) = alignment x+ peekElemOff p i = fmap Identity (peekElemOff (castPtr p) i)+ pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x+ peekByteOff p i = fmap Identity (peekByteOff p i)+ pokeByteOff p i (Identity x) = pokeByteOff p i x+ peek p = fmap runIdentity (peek (castPtr p))+ poke p (Identity x) = poke (castPtr p) x+# endif+#endif++#if !(MIN_VERSION_transformers(0,5,3))+# if !(MIN_VERSION_base(4,9,0))+# if MIN_VERSION_base(4,7,0)+-- Data.Proxy+# if defined(TRANSFORMERS_FOUR)+instance Eq1 Proxy where+ eq1 _ _ = True++instance Ord1 Proxy where+ compare1 _ _ = EQ++instance Show1 Proxy where+ showsPrec1 _ _ = showString "Proxy"++instance Read1 Proxy where+ readsPrec1 d =+ readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])+# elif MIN_VERSION_transformers(0,5,0)+instance Eq1 Proxy where+ liftEq _ _ _ = True++instance Ord1 Proxy where+ liftCompare _ _ _ = EQ++instance Show1 Proxy where+ liftShowsPrec _ _ _ _ = showString "Proxy"++instance Read1 Proxy where+ liftReadsPrec _ _ d =+ readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])+# endif+# endif+# endif++# if !(MIN_VERSION_base(4,8,0))+-- Data.Functor.Identity+instance (Bits a) => Bits (Identity a) where+ Identity x .&. Identity y = Identity (x .&. y)+ Identity x .|. Identity y = Identity (x .|. y)+ xor (Identity x) (Identity y) = Identity (xor x y)+ complement (Identity x) = Identity (complement x)+ shift (Identity x) i = Identity (shift x i)+ rotate (Identity x) i = Identity (rotate x i)+ setBit (Identity x) i = Identity (setBit x i)+ clearBit (Identity x) i = Identity (clearBit x i)+ shiftL (Identity x) i = Identity (shiftL x i)+ shiftR (Identity x) i = Identity (shiftR x i)+ rotateL (Identity x) i = Identity (rotateL x i)+ rotateR (Identity x) i = Identity (rotateR x i)+ testBit (Identity x) i = testBit x i+ bitSize (Identity x) = bitSize x+ isSigned (Identity x) = isSigned x+ bit i = Identity (bit i)+# if MIN_VERSION_base(4,5,0)+ unsafeShiftL (Identity x) i = Identity (unsafeShiftL x i)+ unsafeShiftR (Identity x) i = Identity (unsafeShiftR x i)+ popCount (Identity x) = popCount x+# endif+# if MIN_VERSION_base(4,7,0)+ zeroBits = Identity zeroBits+ bitSizeMaybe (Identity x) = bitSizeMaybe x+# endif++# if MIN_VERSION_base(4,7,0)+instance (FiniteBits a) => FiniteBits (Identity a) where+ finiteBitSize (Identity x) = finiteBitSize x+# endif++instance (Floating a) => Floating (Identity a) where+ pi = Identity pi+ exp (Identity x) = Identity (exp x)+ log (Identity x) = Identity (log x)+ sqrt (Identity x) = Identity (sqrt x)+ sin (Identity x) = Identity (sin x)+ cos (Identity x) = Identity (cos x)+ tan (Identity x) = Identity (tan x)+ asin (Identity x) = Identity (asin x)+ acos (Identity x) = Identity (acos x)+ atan (Identity x) = Identity (atan x)+ sinh (Identity x) = Identity (sinh x)+ cosh (Identity x) = Identity (cosh x)+ tanh (Identity x) = Identity (tanh x)+ asinh (Identity x) = Identity (asinh x)+ acosh (Identity x) = Identity (acosh x)+ atanh (Identity x) = Identity (atanh x)+ Identity x ** Identity y = Identity (x ** y)+ logBase (Identity x) (Identity y) = Identity (logBase x y)++instance (Fractional a) => Fractional (Identity a) where+ Identity x / Identity y = Identity (x / y)+ recip (Identity x) = Identity (recip x)+ fromRational r = Identity (fromRational r)++instance (IsString a) => IsString (Identity a) where+ fromString s = Identity (fromString s)++instance (Integral a) => Integral (Identity a) where+ quot (Identity x) (Identity y) = Identity (quot x y)+ rem (Identity x) (Identity y) = Identity (rem x y)+ div (Identity x) (Identity y) = Identity (div x y)+ mod (Identity x) (Identity y) = Identity (mod x y)+ quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y)+ divMod (Identity x) (Identity y) = (Identity *** Identity) (divMod x y)+ toInteger (Identity x) = toInteger x++instance (Num a) => Num (Identity a) where+ Identity x + Identity y = Identity (x + y)+ Identity x - Identity y = Identity (x - y)+ Identity x * Identity y = Identity (x * y)+ negate (Identity x) = Identity (negate x)+ abs (Identity x) = Identity (abs x)+ signum (Identity x) = Identity (signum x)+ fromInteger n = Identity (fromInteger n)++instance (Real a) => Real (Identity a) where+ toRational (Identity x) = toRational x++instance (RealFloat a) => RealFloat (Identity a) where+ floatRadix (Identity x) = floatRadix x+ floatDigits (Identity x) = floatDigits x+ floatRange (Identity x) = floatRange x+ decodeFloat (Identity x) = decodeFloat x+ exponent (Identity x) = exponent x+ isNaN (Identity x) = isNaN x+ isInfinite (Identity x) = isInfinite x+ isDenormalized (Identity x) = isDenormalized x+ isNegativeZero (Identity x) = isNegativeZero x+ isIEEE (Identity x) = isIEEE x+ significand (Identity x) = significand (Identity x)+ scaleFloat s (Identity x) = Identity (scaleFloat s x)+ encodeFloat m n = Identity (encodeFloat m n)+ atan2 (Identity x) (Identity y) = Identity (atan2 x y)++instance (RealFrac a) => RealFrac (Identity a) where+ properFraction (Identity x) = (id *** Identity) (properFraction x)+ truncate (Identity x) = truncate x+ round (Identity x) = round x+ ceiling (Identity x) = ceiling x+ floor (Identity x) = floor x+# endif++# if MIN_VERSION_transformers(0,3,0)+-- Data.Functor.Reverse+instance (Monad m) => Monad (Reverse m) where+ return a = Reverse (return a)+ {-# INLINE return #-}+ m >>= f = Reverse (getReverse m >>= getReverse . f)+ {-# INLINE (>>=) #-}+ fail msg = Reverse (fail msg)+ {-# INLINE fail #-}++# if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where+ fail msg = Reverse (Fail.fail msg)+ {-# INLINE fail #-}+# endif++instance (MonadPlus m) => MonadPlus (Reverse m) where+ mzero = Reverse mzero+ {-# INLINE mzero #-}+ Reverse x `mplus` Reverse y = Reverse (x `mplus` y)+ {-# INLINE mplus #-}+# endif+#endif++#if !(MIN_VERSION_transformers(0,5,4))+# if MIN_VERSION_base(4,10,0)+instance Bifoldable Constant where+ bifoldMap f _ (Constant a) = f a+ {-# INLINE bifoldMap #-}++instance Bitraversable Constant where+ bitraverse f _ (Constant a) = Constant <$> f a+ {-# INLINE bitraverse #-}+# endif+#endif++#if !(MIN_VERSION_transformers(0,5,5))+# if MIN_VERSION_base(4,9,0)+instance (Semigroup.Semigroup a) => Semigroup.Semigroup (Constant a b) where+ Constant x <> Constant y = Constant (x Semigroup.<> y)+ {-# INLINE (<>) #-}+# endif+#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)))@@ -292,9 +562,9 @@ instance Datatype MDIdentity where datatypeName _ = "Identity" moduleName _ = "Data.Functor.Identity"-# if __GLASGOW_HASKELL__ >= 708+# if __GLASGOW_HASKELL__ >= 708 isNewtype _ = True-# endif+# endif instance Constructor MCIdentity where conName _ = "Identity"@@ -302,15 +572,9 @@ instance Selector MSIdentity where selName _ = "runIdentity"-# endif--# if __GLASGOW_HASKELL__ >= 708-deriving instance Typeable 'Identity-# endif # endif # if !(MIN_VERSION_base(4,9,0))-# if __GLASGOW_HASKELL__ >= 702 -- Generic(1) instances for Compose instance Generic (Compose f g a) where type Rep (Compose f g a) =@@ -335,9 +599,9 @@ instance Datatype MDCompose where datatypeName _ = "Compose" moduleName _ = "Data.Functor.Compose"-# if __GLASGOW_HASKELL__ >= 708+# if __GLASGOW_HASKELL__ >= 708 isNewtype _ = True-# endif+# endif instance Constructor MCCompose where conName _ = "Compose"@@ -372,15 +636,44 @@ instance Constructor MCPair where conName _ = "Pair"-# endif -# 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)+-- Generic(1) instances for Sum+-- These are also present in Data.Functor.Sum in transformers-compat, but only+-- these are reachable if using @transformers-0.4.0.0@ or later+instance Generic (Sum f g a) where+ type Rep (Sum f g a) =+ D1 MDSum (C1 MCInL (S1 NoSelector (Rec0 (f a)))+ :+: C1 MCInR (S1 NoSelector (Rec0 (g a))))+ from (InL f) = M1 (L1 (M1 (M1 (K1 f))))+ from (InR g) = M1 (R1 (M1 (M1 (K1 g))))+ to (M1 (L1 (M1 (M1 (K1 f))))) = InL f+ to (M1 (R1 (M1 (M1 (K1 g))))) = InR g++instance Generic1 (Sum f g) where+ type Rep1 (Sum f g) =+ D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f))+ :+: C1 MCInR (S1 NoSelector (Rec1 g)))+ from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f))))+ from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g))))+ to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f)+ to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g)++data MDSum+data MCInL+data MCInR++instance Datatype MDSum where+ datatypeName _ = "Sum"+ moduleName _ = "Data.Functor.Sum"++instance Constructor MCInL where+ conName _ = "InL"++instance Constructor MCInR where+ conName _ = "InR" # endif # endif+ # endif #endif
+ tests/GenericsSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+module GenericsSpec (main, spec) where++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative+#endif++import Data.Functor.Classes+import Data.Proxy (Proxy(..))++import GenericsTypes++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary)++import Text.Read (minPrec)++main :: IO ()+main = hspec spec++prop_Eq :: (Eq a, Eq (f a), Eq1 f) => f a -> f a -> Bool+prop_Eq x y = (x == y) == 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)++prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Bool+prop_Ord x y = compare x y == 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)++-- Adapted from the definition of readEither+readEither' :: String -> (Int -> ReadS a) -> Either String a+readEither' s rs =+ case [ x | (x,"") <- rs minPrec s ] of+ [x] -> Right x+ [] -> Left "Prelude.read: no parse"+ _ -> Left "Prelude.read: ambiguous parse"++read' :: String -> (Int -> ReadS a) -> a+read' s = either error id . readEither' s++prop_Read :: forall f a. (Read a, Read (f a), Read1 f,+ Eq (f a), Show (f a))+ => f a -> Bool+prop_Read x = readArb readsPrec == readArb readsPrec1+ where+ readArb :: (Int -> ReadS (f a)) -> f a+ readArb = read' (show x)++readSpec :: forall f a. (Arbitrary (f a), Eq (f a), Show (f a),+ Read a, Read (f a), Read1 f)+ => Proxy (f a) -> Spec+readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Bool)++prop_Show :: (Show a, Show (f a), Show1 f) => Int -> f a -> Bool+prop_Show p x = showsPrec p x "" == 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)++classes1Spec :: forall f a. (Arbitrary (f a),+ Ord a, Ord (f a), Ord1 f,+ Read a, Read (f a), Read1 f,+ Show a, Show (f a), Show1 f)+ => String -> Proxy (f a) -> Spec+classes1Spec str proxy =+ describe str $ eqSpec proxy+ *> ordSpec proxy+ *> readSpec proxy+ *> showSpec proxy++spec :: Spec+spec = parallel $ do+ classes1Spec "TestParam" (Proxy :: Proxy (TestParam Int))+ classes1Spec "T#" (Proxy :: Proxy (T# Int))+ classes1Spec "Infix" (Proxy :: Proxy (Infix Int))+ classes1Spec "GADT" (Proxy :: Proxy (GADT Int))+ classes1Spec "Record" (Proxy :: Proxy (Record Int))+ describe "Prim" $+ let proxy :: Proxy (Prim Int)+ proxy = Proxy+ in eqSpec proxy+ *> ordSpec proxy+ *> showSpec proxy
+ tests/GenericsTypes.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}+{-# 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__ < 800+import Generics.Deriving.TH (deriveAll1)+#endif+#if __GLASGOW_HASKELL__ >= 706+import GHC.Generics (Generic1)+#endif+import GHC.Exts++import Test.QuickCheck (Arbitrary(..), oneof)++#if __GLASGOW_HASKELL__ < 702+import Text.Read.Deriving (deriveRead)+#endif++data TestParam a = TestParam a (Maybe a) (Maybe (Maybe a))+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (TestParam a) where+ arbitrary = TestParam <$> arbitrary <*> arbitrary <*> arbitrary++data Prim a = Prim a Char# Double# Int# Float# Word#+ deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (Prim a) where+ arbitrary = do+ a <- arbitrary+ C# c <- arbitrary+ D# d <- arbitrary+ I# i <- arbitrary+ F# f <- arbitrary+ W# w <- arbitrary+ return $ Prim a c d i f w++data T# a = MkT1# a+ | MkT2# { getT2# :: a, (##) :: a }+ | a `MkT3#` a+ deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (T# a) where+ arbitrary = oneof [ MkT1# <$> arbitrary+ , MkT2# <$> arbitrary <*> arbitrary+ , MkT3# <$> arbitrary <*> arbitrary+ ]++infixl 3 :!:+infix 4 :@:+infixr 5 `Backticks`+infixr 6 `FakeInfix`+data Infix a = (:!:) a Double+ | a :@: ()+ | a `Backticks` Bool+ | FakeInfix a Int+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (Infix a) where+ arbitrary = oneof [ (:!:) <$> arbitrary <*> arbitrary+ , (:@:) <$> arbitrary <*> arbitrary+ , Backticks <$> arbitrary <*> arbitrary+ , FakeInfix <$> arbitrary <*> arbitrary+ ]++infixr 1 :., :..., :....+data GADT a where+ (:.) :: b -> () -> GADT b+ (:..) :: c -> Bool -> GADT c+ (:...) :: d -> Double -> Int -> GADT d+ (:....) :: { gadt1 :: e, gadt2 :: Char } -> GADT e+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (GADT a) where+ arbitrary = oneof [ (:.) <$> arbitrary <*> arbitrary+ , (:..) <$> arbitrary <*> arbitrary+ , (:...) <$> arbitrary <*> arbitrary <*> arbitrary+ , (:....) <$> arbitrary <*> arbitrary+ ]++infixl 4 :%:+data Record a = Prefix { rec1 :: Int, rec2 :: a }+ | Int :%: a+ deriving (Eq, Ord, Read, Show)++instance Arbitrary a => Arbitrary (Record a) where+ arbitrary = oneof [ Prefix <$> arbitrary <*> arbitrary+ , (:%:) <$> arbitrary <*> arbitrary+ ]++#if __GLASGOW_HASKELL__ >= 702+deriving instance Read a => Read (T# a)+#else+-- Workaround for GHC Trac #5041+$(deriveRead ''T#)+#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 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 CLASS1_INSTANCES(type) \+EQ1_INSTANCE(type) \+ORD1_INSTANCE(type) \+READ1_INSTANCE(type) \+SHOW1_INSTANCE(type) \++CLASS1_INSTANCES(TestParam)+CLASS1_INSTANCES(T#)+CLASS1_INSTANCES(Infix)+CLASS1_INSTANCES(GADT)+CLASS1_INSTANCES(Record)++EQ1_INSTANCE(Prim)+ORD1_INSTANCE(Prim)+SHOW1_INSTANCE(Prim)
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
transformers-compat.cabal view
@@ -1,6 +1,6 @@ name: transformers-compat category: Compatibility-version: 0.5.1.4+version: 0.6.0.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -10,7 +10,7 @@ homepage: http://github.com/ekmett/transformers-compat/ bug-reports: http://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett-synopsis: A small compatibility shim exposing the new types from transformers 0.3 and 0.4 to older Haskell platforms.+synopsis: A small compatibility shim for the transformers library description: This package includes backported versions of types that were added to transformers in transformers 0.3, 0.4, and 0.5 for users who need strict@@ -23,7 +23,15 @@ Note: missing methods are not supplied, but this at least permits the types to be used. build-type: Simple-tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.8.2, GHC == 7.10.3, GHC == 8.0.1+tested-with: GHC == 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+ , GHC == 8.2.2+ , GHC == 8.4.1 extra-source-files: .travis.yml .ghci@@ -39,7 +47,7 @@ location: git://github.com/ekmett/transformers-compat.git flag two- default: False+ default: True description: Use transformers 0.2. This will be selected by cabal picking the appropriate version. manual: True @@ -48,11 +56,30 @@ manual: True description: Use transformers 0.3. This will be selected by cabal picking the appropriate version. +flag four+ default: False+ manual: True+ description: Use transformers 0.4. This will be selected by cabal picking the appropriate version.++flag five+ default: False+ manual: True+ description: Use transformers 0.5 up until (but not including) 0.5.3. This will be selected by cabal picking the appropriate version.+ flag mtl default: True manual: True- description: -f-mtl Disables support for mtl for transformers 0.2 and 0.3. That is an unsupported configuration, and results in missing instances for `ExceptT`, but keeps the package Haskell 98.+ description: -f-mtl Disables support for mtl for transformers 0.2 and 0.3. That is an unsupported configuration, and results in missing instances for `ExceptT`. +flag generic-deriving+ default: True+ manual: True+ description: -f-generic-deriving prevents generic-deriving from being built as a dependency.+ This disables certain aspects of generics for older versions of GHC. In particular,+ Generic(1) instances will not be backported prior to GHC 7.2, and generic operations+ over unlifted types will not be backported prior to GHC 8.0. This is an unsupported+ configuration.+ library build-depends: base >= 4.3 && < 5@@ -66,25 +93,44 @@ other-modules: Paths_transformers_compat - if flag(three)- hs-source-dirs: 0.3- build-depends:- transformers >= 0.3 && < 0.4,- mtl >= 2.1 && < 2.2+ if flag(five)+ hs-source-dirs: 0.5+ build-depends: transformers >= 0.5 && < 0.5.3 else- if flag(two)- hs-source-dirs: 0.2 0.3- build-depends:- transformers >= 0.2 && < 0.3,- mtl >= 2.0 && < 2.1+ if flag(four)+ cpp-options: -DTRANSFORMERS_FOUR+ hs-source-dirs: 0.5+ build-depends: transformers >= 0.4 && < 0.5 else- build-depends: transformers >= 0.4.1 && < 0.6+ 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+ 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.5.3 && < 0.6 - if !flag(mtl)- cpp-options: -DHASKELL98- else+ if impl(ghc >= 7.2) || flag(generic-deriving)+ hs-source-dirs: generics build-depends: ghc-prim + 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@@ -97,3 +143,38 @@ Control.Monad.Signatures Data.Functor.Classes Data.Functor.Sum++ if flag(two) || flag(three) || 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++test-suite spec+ if !impl(ghc >= 8.0) && !flag(generic-deriving)+ buildable: False++ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: GenericsSpec+ GenericsTypes+ build-depends: base >= 4.3 && < 5+ , deriving-compat >= 0.3.4 && < 1+ , hspec >= 2 && < 3+ , QuickCheck >= 2 && < 3+ , tagged >= 0.7 && < 1+ , transformers >= 0.2 && < 0.6+ , transformers-compat++ if !impl(ghc >= 8.0)+ build-depends: generic-deriving >= 1.10 && < 2++ if flag(four)+ cpp-options: -DTRANSFORMERS_FOUR++ hs-source-dirs: tests+ ghc-options: -Wall -threaded -rtsopts