diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ dist +dist-newstyle docs wiki TAGS @@ -7,3 +8,25 @@ .DS_Store .*.swp .*.swo +*.o +*.hi +*~ +*# +.stack-work/ +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/0.2/Control/Applicative/Backwards.hs b/0.2/Control/Applicative/Backwards.hs --- a/0.2/Control/Applicative/Backwards.hs +++ b/0.2/Control/Applicative/Backwards.hs @@ -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 #-} diff --git a/0.2/Control/Applicative/Lift.hs b/0.2/Control/Applicative/Lift.hs --- a/0.2/Control/Applicative/Lift.hs +++ b/0.2/Control/Applicative/Lift.hs @@ -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 diff --git a/0.2/Data/Functor/Reverse.hs b/0.2/Data/Functor/Reverse.hs --- a/0.2/Data/Functor/Reverse.hs +++ b/0.2/Data/Functor/Reverse.hs @@ -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 #-} diff --git a/0.3/Control/Monad/Signatures.hs b/0.3/Control/Monad/Signatures.hs --- a/0.3/Control/Monad/Signatures.hs +++ b/0.3/Control/Monad/Signatures.hs @@ -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 #-} diff --git a/0.3/Control/Monad/Trans/Except.hs b/0.3/Control/Monad/Trans/Except.hs --- a/0.3/Control/Monad/Trans/Except.hs +++ b/0.3/Control/Monad/Trans/Except.hs @@ -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 diff --git a/0.3/Data/Functor/Classes.hs b/0.3/Data/Functor/Classes.hs --- a/0.3/Data/Functor/Classes.hs +++ b/0.3/Data/Functor/Classes.hs @@ -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 diff --git a/0.3/Data/Functor/Sum.hs b/0.3/Data/Functor/Sum.hs --- a/0.3/Data/Functor/Sum.hs +++ b/0.3/Data/Functor/Sum.hs @@ -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) = diff --git a/0.5/Control/Monad/Trans/Accum.hs b/0.5/Control/Monad/Trans/Accum.hs new file mode 100644 --- /dev/null +++ b/0.5/Control/Monad/Trans/Accum.hs @@ -0,0 +1,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 #-} diff --git a/0.5/Control/Monad/Trans/Select.hs b/0.5/Control/Monad/Trans/Select.hs new file mode 100644 --- /dev/null +++ b/0.5/Control/Monad/Trans/Select.hs @@ -0,0 +1,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. +-- +-- +-- * Jules Hedges. "Monad transformers for backtracking search". +-- In /Proceedings of MSFP 2014/. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Select ( + -- * The Select monad + Select, + select, + runSelect, + mapSelect, + -- * The SelectT monad transformer + SelectT(SelectT), + runSelectT, + mapSelectT, + -- * Monad transformation + selectToContT, + 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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 ----- diff --git a/generics/Data/Functor/Classes/Generic.hs b/generics/Data/Functor/Classes/Generic.hs new file mode 100644 --- /dev/null +++ b/generics/Data/Functor/Classes/Generic.hs @@ -0,0 +1,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 +@ +-} diff --git a/generics/Data/Functor/Classes/Generic/Internal.hs b/generics/Data/Functor/Classes/Generic/Internal.hs new file mode 100644 --- /dev/null +++ b/generics/Data/Functor/Classes/Generic/Internal.hs @@ -0,0 +1,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 diff --git a/src/Control/Monad/Trans/Instances.hs b/src/Control/Monad/Trans/Instances.hs --- a/src/Control/Monad/Trans/Instances.hs +++ b/src/Control/Monad/Trans/Instances.hs @@ -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 diff --git a/tests/GenericsSpec.hs b/tests/GenericsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/GenericsSpec.hs @@ -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 diff --git a/tests/GenericsTypes.hs b/tests/GenericsTypes.hs new file mode 100644 --- /dev/null +++ b/tests/GenericsTypes.hs @@ -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) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/transformers-compat.cabal b/transformers-compat.cabal --- a/transformers-compat.cabal +++ b/transformers-compat.cabal @@ -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