transformers-compat-0.6.5/0000755000000000000000000000000007346545000013721 5ustar0000000000000000transformers-compat-0.6.5/.ghci0000755000000000000000000000012507346545000014635 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h transformers-compat-0.6.5/.gitignore0000755000000000000000000000043007346545000015711 0ustar0000000000000000dist dist-newstyle docs wiki TAGS tags wip .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.* transformers-compat-0.6.5/.travis.yml0000755000000000000000000002547207346545000016047 0ustar0000000000000000# This Travis job script has been generated by a script via # # haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' # # For more information, see https://github.com/haskell-CI/haskell-ci # # version: 0.3.20190425 # language: c dist: xenial git: # whether to recursively clone submodules submodules: false notifications: irc: channels: - irc.freenode.org#haskell-lens skip_join: true template: - "\"\\x0313transformers-compat\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\"" cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - compiler: ghc-8.8.1 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} env: GHCHEAD=true - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - compiler: ghc-8.4.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} - compiler: ghc-8.2.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} - compiler: ghc-7.10.3 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4"]}} - compiler: ghc-7.8.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4"]}} - compiler: ghc-7.6.3 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.6.3","cabal-install-2.4"]}} - compiler: ghc-7.4.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.4.2","cabal-install-2.4"]}} - compiler: ghc-7.2.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.2.2","cabal-install-2.4"]}} - compiler: ghc-7.0.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.0.4","cabal-install-2.4"]}} - compiler: ghc-head addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-head","cabal-install-head"]}} env: GHCHEAD=true allow_failures: - compiler: ghc-head - compiler: ghc-8.8.1 before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal - CABALHOME=$HOME/.cabal - export PATH="$CABALHOME/bin:$PATH" - TOP=$(pwd) - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - echo $HCNUMVER - CABAL="$CABAL -vnormal+nowrap+markoutput" - set -o pipefail - | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk echo 'BEGIN { state = "output"; }' >> .colorful.awk echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk echo ' if (state == "cabal") {' >> .colorful.awk echo ' print blue($0)' >> .colorful.awk echo ' } else {' >> .colorful.awk echo ' print $0' >> .colorful.awk echo ' }' >> .colorful.awk echo '}' >> .colorful.awk - cat .colorful.awk - | color_cabal_output () { awk -f $TOP/.colorful.awk } - echo text | color_cabal_output install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - GHCHEAD=${GHCHEAD-false} - rm -f $CABALHOME/config - | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config echo "remote-build-reporting: anonymous" >> $CABALHOME/config echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config echo "world-file: $CABALHOME/world" >> $CABALHOME/config echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config echo "installdir: $CABALHOME/bin" >> $CABALHOME/config echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config echo "store-dir: $CABALHOME/store" >> $CABALHOME/config echo "install-dirs user" >> $CABALHOME/config echo " prefix: $CABALHOME" >> $CABALHOME/config echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - | if $GHCHEAD; then echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config echo "repository head.hackage" >> $CABALHOME/config echo " url: http://head.hackage.haskell.org/" >> $CABALHOME/config echo " secure: True" >> $CABALHOME/config echo " root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740" >> $CABALHOME/config echo " 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb" >> $CABALHOME/config echo " 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e" >> $CABALHOME/config echo " key-threshold: 3" >> $CABALHOME/config fi - "echo 'jobs: 2' >> $CABALHOME/config" - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo 'packages: "."' >> cabal.project echo 'packages: "./tests"' >> cabal.project - | echo "write-ghc-environment-files: always" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(transformers-compat|transformers-compat-tests)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - if [ -f "./tests/configure.ac" ]; then (cd "./tests" && autoreconf -i); fi - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - ${CABAL} v2-sdist all | color_cabal_output # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo 'packages: "transformers-compat-*/*.cabal"' >> cabal.project echo 'packages: "transformers-compat-tests-*/*.cabal"' >> cabal.project - | echo "write-ghc-environment-files: always" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(transformers-compat|transformers-compat-tests)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true # Building with tests and benchmarks... # build & run tests, build benchmarks - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # Testing... - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # cabal check... - (cd transformers-compat-* && ${CABAL} -vnormal check) - (cd transformers-compat-tests-* && ${CABAL} -vnormal check) # haddock... - ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # Building without installed constraints for packages in global-db... - rm -f cabal.project.local - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output # Constraint sets - rm -rf cabal.project.local # Constraint set no-mtl - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers-compat -mtl' all | color_cabal_output # Constraint set no-generic-deriving - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers-compat -generic-deriving' all | color_cabal_output # Constraint set no-mtl-no-generic-deriving - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers-compat -generic-deriving' --constraint='tranformers-compat -mtl' all | color_cabal_output # Constraint set two - if [ $HCNUMVER -lt 70900 ] ; then ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers-compat +two' all | color_cabal_output ; fi # Constraint set three - if [ $HCNUMVER -lt 70900 ] ; then ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers-compat +three' all | color_cabal_output ; fi # Constraint set four - if [ $HCNUMVER -lt 71100 ] ; then ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers-compat +four' all | color_cabal_output ; fi # Constraint set five - if [ $HCNUMVER -lt 80300 ] ; then ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers-compat +five' all | color_cabal_output ; fi # Constraint set transformers-installed - if [ $HCNUMVER -ge 70800 ] ; then ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers installed' all | color_cabal_output ; fi # Constraint set transformers-newer - if [ $HCNUMVER -lt 80500 ] ; then ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --constraint='transformers >=0.5.5.0' all | color_cabal_output ; fi # REGENDATA ["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"] # EOF transformers-compat-0.6.5/.vim.custom0000755000000000000000000000137707346545000016041 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" transformers-compat-0.6.5/0.2/Control/Applicative/0000755000000000000000000000000007346545000020101 5ustar0000000000000000transformers-compat-0.6.5/0.2/Control/Applicative/Backwards.hs0000644000000000000000000000626507346545000022347 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif #endif -- | -- Module : Control.Applicative.Backwards -- Copyright : (c) Russell O'Connor 2009 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- Making functors with an 'Applicative' instance that performs actions -- in the reverse order. -- -- NB: This module is only included in @lens@ for backwards compatibility with -- @transformers@ versions before 3.0. module Control.Applicative.Backwards where import Data.Functor.Classes import Prelude hiding (foldr, foldr1, foldl, foldl1) import Control.Applicative import Data.Foldable import Data.Traversable -- | The same functor, but with an 'Applicative' instance that performs -- actions in the reverse order. newtype Backwards f a = Backwards { forwards :: f a } instance (Eq1 f) => Eq1 (Backwards f) where liftEq eq (Backwards x) (Backwards y) = liftEq eq x y {-# INLINE liftEq #-} instance (Ord1 f) => Ord1 (Backwards f) where liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y {-# INLINE liftCompare #-} instance (Read1 f) => Read1 (Backwards f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards instance (Show1 f) => Show1 (Backwards f) where liftShowsPrec sp sl d (Backwards x) = showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 -- | Derived instance. instance (Functor f) => Functor (Backwards f) where fmap f (Backwards a) = Backwards (fmap f a) {-# INLINE fmap #-} -- | Apply @f@-actions in the reverse order. instance (Applicative f) => Applicative (Backwards f) where pure a = Backwards (pure a) {-# INLINE pure #-} Backwards f <*> Backwards a = Backwards (a <**> f) {-# INLINE (<*>) #-} -- | Try alternatives in the same order as @f@. instance (Alternative f) => Alternative (Backwards f) where empty = Backwards empty {-# INLINE empty #-} Backwards x <|> Backwards y = Backwards (x <|> y) {-# INLINE (<|>) #-} -- | Derived instance. instance (Foldable f) => Foldable (Backwards f) where foldMap f (Backwards t) = foldMap f t {-# INLINE foldMap #-} foldr f z (Backwards t) = foldr f z t {-# INLINE foldr #-} foldl f z (Backwards t) = foldl f z t {-# INLINE foldl #-} foldr1 f (Backwards t) = foldr1 f t {-# INLINE foldr1 #-} foldl1 f (Backwards t) = foldl1 f t {-# INLINE foldl1 #-} -- | Derived instance. instance (Traversable f) => Traversable (Backwards f) where traverse f (Backwards t) = fmap Backwards (traverse f t) {-# INLINE traverse #-} sequenceA (Backwards t) = fmap Backwards (sequenceA t) {-# INLINE sequenceA #-} transformers-compat-0.6.5/0.2/Control/Applicative/Lift.hs0000644000000000000000000001174707346545000021345 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif #endif -- | -- Module : Control.Applicative.Lift -- Copyright : (c) Ross Paterson 2010 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- Adding a new kind of pure computation to an applicative functor. -- -- NB: This module is only included in @lens@ for backwards compatibility with -- @transformers@ versions before 3.0. module Control.Applicative.Lift ( -- * Lifting an applicative Lift(..), unLift, mapLift, elimLift, -- * Collecting errors Errors, runErrors, failure, eitherToErrors ) where import Data.Functor.Classes import Control.Applicative import Data.Foldable (Foldable(foldMap)) import Data.Functor.Constant import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) -- | Applicative functor formed by adding pure computations to a given -- applicative functor. data Lift f a = Pure a | Other (f a) instance (Eq1 f) => Eq1 (Lift f) where liftEq eq (Pure x1) (Pure x2) = eq x1 x2 liftEq _ (Pure _) (Other _) = False liftEq _ (Other _) (Pure _) = False liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 {-# INLINE liftEq #-} instance (Ord1 f) => Ord1 (Lift f) where liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 liftCompare _ (Pure _) (Other _) = LT liftCompare _ (Other _) (Pure _) = GT liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 {-# INLINE liftCompare #-} instance (Read1 f) => Read1 (Lift f) where liftReadsPrec rp rl = readsData $ readsUnaryWith rp "Pure" Pure `mappend` readsUnaryWith (liftReadsPrec rp rl) "Other" Other instance (Show1 f) => Show1 (Lift f) where liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x liftShowsPrec sp sl d (Other y) = showsUnaryWith (liftShowsPrec sp sl) "Other" d y instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 instance (Functor f) => Functor (Lift f) where fmap f (Pure x) = Pure (f x) fmap f (Other y) = Other (fmap f y) {-# INLINE fmap #-} instance (Foldable f) => Foldable (Lift f) where foldMap f (Pure x) = f x foldMap f (Other y) = foldMap f y {-# INLINE foldMap #-} instance (Traversable f) => Traversable (Lift f) where traverse f (Pure x) = Pure <$> f x traverse f (Other y) = Other <$> traverse f y {-# INLINE traverse #-} -- | A combination is 'Pure' only if both parts are. instance (Applicative f) => Applicative (Lift f) where pure = Pure {-# INLINE pure #-} Pure f <*> Pure x = Pure (f x) Pure f <*> Other y = Other (f <$> y) Other f <*> Pure x = Other (($ x) <$> f) Other f <*> Other y = Other (f <*> y) {-# INLINE (<*>) #-} -- | A combination is 'Pure' only either part is. instance (Alternative f) => Alternative (Lift f) where empty = Other empty {-# INLINE empty #-} Pure x <|> _ = Pure x Other _ <|> Pure y = Pure y Other x <|> Other y = Other (x <|> y) {-# INLINE (<|>) #-} -- | Projection to the other functor. unLift :: (Applicative f) => Lift f a -> f a unLift (Pure x) = pure x unLift (Other e) = e {-# INLINE unLift #-} -- | Apply a transformation to the other computation. mapLift :: (f a -> g a) -> Lift f a -> Lift g a mapLift _ (Pure x) = Pure x mapLift f (Other e) = Other (f e) {-# INLINE mapLift #-} -- | Eliminator for 'Lift'. -- -- * @'elimLift' f g . 'pure' = f@ -- -- * @'elimLift' f g . 'Other' = g@ -- elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r elimLift f _ (Pure x) = f x elimLift _ g (Other e) = g e {-# INLINE elimLift #-} -- | An applicative functor that collects a monoid (e.g. lists) of errors. -- A sequence of computations fails if any of its components do, but -- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except", -- these computations continue after an error, collecting all the errors. -- -- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@ -- -- * @'pure' f '<*>' 'failure' e = 'failure' e@ -- -- * @'failure' e '<*>' 'pure' x = 'failure' e@ -- -- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@ -- type Errors e = Lift (Constant e) -- | Extractor for computations with accumulating errors. -- -- * @'runErrors' ('pure' x) = 'Right' x@ -- -- * @'runErrors' ('failure' e) = 'Left' e@ -- runErrors :: Errors e a -> Either e a runErrors (Other (Constant e)) = Left e runErrors (Pure x) = Right x {-# INLINE runErrors #-} -- | Report an error. failure :: e -> Errors e a failure e = Other (Constant e) {-# INLINE failure #-} -- | Convert from 'Either' to 'Errors' (inverse of 'runErrors'). eitherToErrors :: Either e a -> Errors e a eitherToErrors = either failure Pure transformers-compat-0.6.5/0.2/Data/Functor/0000755000000000000000000000000007346545000016511 5ustar0000000000000000transformers-compat-0.6.5/0.2/Data/Functor/Reverse.hs0000644000000000000000000000746707346545000020476 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif #endif -- | -- Module : Data.Functor.Reverse -- Copyright : (c) Russell O'Connor 2009 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- Making functors whose elements are notionally in the reverse order -- from the original functor. -- -- /NB:/ Note this module is only included in @lens@ for backwards -- compatibility with older @containers@ versions. module Data.Functor.Reverse where import Control.Applicative.Backwards import Data.Functor.Classes import Prelude hiding (foldr, foldr1, foldl, foldl1) import Control.Applicative import Control.Monad #if MIN_VERSION_base(4,9,0) import qualified Control.Monad.Fail as Fail #endif import Data.Foldable import Data.Traversable import Data.Monoid -- | The same functor, but with 'Foldable' and 'Traversable' instances -- that process the elements in the reverse order. newtype Reverse f a = Reverse { getReverse :: f a } instance (Eq1 f) => Eq1 (Reverse f) where liftEq eq (Reverse x) (Reverse y) = liftEq eq x y {-# INLINE liftEq #-} instance (Ord1 f) => Ord1 (Reverse f) where liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y {-# INLINE liftCompare #-} instance (Read1 f) => Read1 (Reverse f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse instance (Show1 f) => Show1 (Reverse f) where liftShowsPrec sp sl d (Reverse x) = showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 -- | Derived instance. instance (Functor f) => Functor (Reverse f) where fmap f (Reverse a) = Reverse (fmap f a) {-# INLINE fmap #-} -- | Derived instance. instance (Applicative f) => Applicative (Reverse f) where pure a = Reverse (pure a) {-# INLINE pure #-} Reverse f <*> Reverse a = Reverse (f <*> a) {-# INLINE (<*>) #-} -- | Derived instance. instance (Alternative f) => Alternative (Reverse f) where empty = Reverse empty {-# INLINE empty #-} Reverse x <|> Reverse y = Reverse (x <|> y) {-# INLINE (<|>) #-} -- | Derived instance. instance (Monad m) => Monad (Reverse m) where return a = Reverse (return a) {-# INLINE return #-} m >>= f = Reverse (getReverse m >>= getReverse . f) {-# INLINE (>>=) #-} fail msg = Reverse (fail msg) {-# INLINE fail #-} -- | Derived instance. instance (MonadPlus m) => MonadPlus (Reverse m) where mzero = Reverse mzero {-# INLINE mzero #-} Reverse x `mplus` Reverse y = Reverse (x `mplus` y) {-# INLINE mplus #-} -- | Fold from right to left. instance (Foldable f) => Foldable (Reverse f) where foldMap f (Reverse t) = getDual (foldMap (Dual . f) t) {-# INLINE foldMap #-} foldr f z (Reverse t) = foldl (flip f) z t {-# INLINE foldr #-} foldl f z (Reverse t) = foldr (flip f) z t {-# INLINE foldl #-} foldr1 f (Reverse t) = foldl1 (flip f) t {-# INLINE foldr1 #-} foldl1 f (Reverse t) = foldr1 (flip f) t {-# INLINE foldl1 #-} -- | Traverse from right to left. instance (Traversable f) => Traversable (Reverse f) where traverse f (Reverse t) = fmap Reverse . forwards $ traverse (Backwards . f) t {-# INLINE traverse #-} sequenceA (Reverse t) = fmap Reverse . forwards $ sequenceA (fmap Backwards t) {-# INLINE sequenceA #-} transformers-compat-0.6.5/0.3/Control/Monad/0000755000000000000000000000000007346545000016677 5ustar0000000000000000transformers-compat-0.6.5/0.3/Control/Monad/Signatures.hs0000644000000000000000000000346007346545000021362 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Signatures -- Copyright : (c) Ross Paterson 2012 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- Signatures for monad operations that require specialized lifting. -- Each signature has a uniformity property that the lifting should satisfy. ----------------------------------------------------------------------------- module Control.Monad.Signatures ( CallCC, Catch, Listen, Pass ) where -- | Signature of the @callCC@ operation, -- introduced in "Control.Monad.Trans.Cont". -- Any lifting function @liftCallCC@ should satisfy -- -- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@ -- type CallCC m a b = ((a -> m b) -> m a) -> m a -- | Signature of the @catchE@ operation, -- introduced in "Control.Monad.Trans.Except". -- Any lifting function @liftCatch@ should satisfy -- -- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@ -- type Catch e m a = m a -> (e -> m a) -> m a -- | Signature of the @listen@ operation, -- introduced in "Control.Monad.Trans.Writer". -- Any lifting function @liftListen@ should satisfy -- -- * @'lift' . liftListen = liftListen . 'lift'@ -- type Listen w m a = m a -> m (a, w) -- | Signature of the @pass@ operation, -- introduced in "Control.Monad.Trans.Writer". -- Any lifting function @liftPass@ should satisfy -- -- * @'lift' . liftPass = liftPass . 'lift'@ -- type Pass w m a = m (a, w -> w) -> m a transformers-compat-0.6.5/0.3/Control/Monad/Trans/0000755000000000000000000000000007346545000017766 5ustar0000000000000000transformers-compat-0.6.5/0.3/Control/Monad/Trans/Except.hs0000644000000000000000000002476507346545000021570 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 #endif #ifdef MTL {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Except -- Copyright : (C) 2013 Ross Paterson -- (C) 2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- This monad transformer extends a monad with the ability throw exceptions. -- -- A sequence of actions terminates normally, producing a value, -- only if none of the actions in the sequence throws an exception. -- If one throws an exception, the rest of the sequence is skipped and -- the composite action exits with that exception. -- -- If the value of the exception is not required, the variant in -- "Control.Monad.Trans.Maybe" may be used instead. ----------------------------------------------------------------------------- module Control.Monad.Trans.Except ( -- * The Except monad Except, except, runExcept, mapExcept, withExcept, -- * The ExceptT monad transformer ExceptT(..), mapExceptT, withExceptT, -- * Exception operations throwE, catchE, -- * Lifting other operations liftCallCC, liftListen, liftPass, ) where import Control.Applicative import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Signatures import Control.Monad.Trans.Class #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip (MonadZip(mzipWith)) #endif #ifdef MTL import Control.Monad.Writer.Class import Control.Monad.State.Class import Control.Monad.Reader.Class import Control.Monad.Cont.Class import Control.Monad.Error.Class import Control.Monad.RWS.Class #endif import Data.Foldable (Foldable(foldMap)) import Data.Functor.Classes import Data.Functor.Identity import Data.Monoid import Data.Traversable (Traversable(traverse)) -- | The parameterizable exception monad. -- -- Computations are either exceptions or normal values. -- -- The 'return' function returns a normal value, while @>>=@ exits -- on the first exception. type Except e = ExceptT e Identity -- | Constructor for computations in the exception monad. -- (The inverse of 'runExcept'). except :: (Monad m) => Either e a -> ExceptT e m a except m = ExceptT (return m) {-# INLINE except #-} -- | Extractor for computations in the exception monad. -- (The inverse of 'except'). runExcept :: Except e a -> Either e a runExcept (ExceptT m) = runIdentity m {-# INLINE runExcept #-} -- | Map the unwrapped computation using the given function. -- -- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@ mapExcept :: (Either e a -> Either e' b) -> Except e a -> Except e' b mapExcept f = mapExceptT (Identity . f . runIdentity) {-# INLINE mapExcept #-} -- | Transform any exceptions thrown by the computation using the given -- function (a specialization of 'withExceptT'). withExcept :: (e -> e') -> Except e a -> Except e' a withExcept = withExceptT {-# INLINE withExcept #-} -- | A monad transformer that adds exceptions to other monads. -- -- @ExceptT@ constructs a monad parameterized over two things: -- -- * e - The exception type. -- -- * m - The inner monad. -- -- The 'return' function yields a computation that produces the given -- value, while @>>=@ sequences two subcomputations, exiting on the -- first exception. newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y {-# INLINE liftEq #-} instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where liftCompare comp (ExceptT x) (ExceptT y) = liftCompare (liftCompare comp) x y {-# INLINE liftCompare #-} instance (Read e, Read1 m) => Read1 (ExceptT e m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show e, Show1 m) => Show1 (ExceptT e m) where liftShowsPrec sp sl d (ExceptT m) = showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1 instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1 instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where readsPrec = readsPrec1 instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where showsPrec = showsPrec1 -- | Map the unwrapped computation using the given function. -- -- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b mapExceptT f m = ExceptT $ f (runExceptT m) {-# INLINE mapExceptT #-} -- | Transform any exceptions thrown by the computation using the -- given function. withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a withExceptT f = mapExceptT $ fmap $ either (Left . f) Right {-# INLINE withExceptT #-} instance (Functor m) => Functor (ExceptT e m) where fmap f = ExceptT . fmap (fmap f) . runExceptT {-# INLINE fmap #-} instance (Foldable f) => Foldable (ExceptT e f) where foldMap f (ExceptT a) = foldMap (either (const mempty) f) a {-# INLINE foldMap #-} instance (Traversable f) => Traversable (ExceptT e f) where traverse f (ExceptT a) = ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a {-# INLINE traverse #-} instance (Functor m, Monad m) => Applicative (ExceptT e m) where pure a = ExceptT $ return (Right a) {-# INLINE pure #-} ExceptT f <*> ExceptT v = ExceptT $ do mf <- f case mf of Left e -> return (Left e) Right k -> do mv <- v case mv of Left e -> return (Left e) Right x -> return (Right (k x)) {-# INLINEABLE (<*>) #-} m *> k = m >>= \_ -> k {-# INLINE (*>) #-} instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where empty = ExceptT $ return (Left mempty) {-# INLINE empty #-} ExceptT mx <|> ExceptT my = ExceptT $ do ex <- mx case ex of Left e -> liftM (either (Left . mappend e) Right) my Right x -> return (Right x) {-# INLINEABLE (<|>) #-} instance (Monad m) => Monad (ExceptT e m) where return a = ExceptT $ return (Right a) {-# INLINE return #-} m >>= k = ExceptT $ do a <- runExceptT m case a of Left e -> return (Left e) Right x -> runExceptT (k x) {-# INLINE (>>=) #-} fail = ExceptT . fail {-# INLINE fail #-} instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where fail = ExceptT . Fail.fail {-# INLINE fail #-} instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where mzero = ExceptT $ return (Left mempty) {-# INLINE mzero #-} ExceptT m `mplus` ExceptT n = ExceptT $ do a <- m case a of Left e -> liftM (either (Left . mappend e) Right) n Right x -> return (Right x) {-# INLINEABLE mplus #-} instance (MonadFix m) => MonadFix (ExceptT e m) where mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id)) where bomb = error "mfix (ExceptT): inner computation returned Left value" {-# INLINE mfix #-} instance MonadTrans (ExceptT e) where lift = ExceptT . liftM Right {-# INLINE lift #-} instance (MonadIO m) => MonadIO (ExceptT e m) where liftIO = lift . liftIO {-# INLINE liftIO #-} #if MIN_VERSION_base(4,4,0) instance (MonadZip m) => MonadZip (ExceptT e m) where mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b {-# INLINE mzipWith #-} #endif -- | Signal an exception value @e@. -- -- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@ -- -- * @'throwE' e >>= m = 'throwE' e@ throwE :: (Monad m) => e -> ExceptT e m a throwE = ExceptT . return . Left {-# INLINE throwE #-} -- | Handle an exception. -- -- * @'catchE' h ('lift' m) = 'lift' m@ -- -- * @'catchE' h ('throwE' e) = h e@ catchE :: (Monad m) => ExceptT e m a -- ^ the inner computation -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner -- computation -> ExceptT e' m a m `catchE` h = ExceptT $ do a <- runExceptT m case a of Left l -> runExceptT (h l) Right r -> return (Right r) {-# INLINE catchE #-} -- | Lift a @callCC@ operation to the new monad. liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b liftCallCC callCC f = ExceptT $ callCC $ \ c -> runExceptT (f (\ a -> ExceptT $ c (Right a))) {-# INLINE liftCallCC #-} -- | Lift a @listen@ operation to the new monad. liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a liftListen listen = mapExceptT $ \ m -> do (a, w) <- listen m return $! fmap (\ r -> (r, w)) a {-# INLINE liftListen #-} -- | Lift a @pass@ operation to the new monad. liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a liftPass pass = mapExceptT $ \ m -> pass $ do a <- m return $! case a of Left l -> (Left l, id) Right (r, f) -> (Right r, f) {-# INLINE liftPass #-} -- incurring the mtl dependency for these avoids packages that need them introducing orphans. #ifdef MTL instance Monad m => MonadError e (ExceptT e m) where throwError = throwE catchError = catchE instance MonadWriter w m => MonadWriter w (ExceptT e m) where tell = lift . tell listen = liftListen listen pass = liftPass pass #if MIN_VERSION_mtl(2,1,0) writer = lift . writer #endif instance MonadState s m => MonadState s (ExceptT e m) where get = lift get put = lift . put #if MIN_VERSION_mtl(2,1,0) state = lift . state #endif instance MonadReader r m => MonadReader r (ExceptT e m) where ask = lift ask local = mapExceptT . local #if MIN_VERSION_mtl(2,1,0) reader = lift . reader #endif instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m) instance MonadCont m => MonadCont (ExceptT e m) where callCC = liftCallCC callCC #endif transformers-compat-0.6.5/0.3/Data/Functor/0000755000000000000000000000000007346545000016512 5ustar0000000000000000transformers-compat-0.6.5/0.3/Data/Functor/Classes.hs0000644000000000000000000010013207346545000020440 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_transformers #define MIN_VERSION_transformers(a,b,c) 1 #endif #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} # endif #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Classes -- Copyright : (c) Ross Paterson 2013, Edward Kmett 2014 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental -- Portability : portable -- -- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to -- unary and binary type constructors. -- -- These classes are needed to express the constraints on arguments of -- transformers in portable Haskell. Thus for a new transformer @T@, -- one might write instances like -- -- > instance (Eq1 f) => Eq1 (T f) where ... -- > instance (Ord1 f) => Ord1 (T f) where ... -- > instance (Read1 f) => Read1 (T f) where ... -- > instance (Show1 f) => Show1 (T f) where ... -- -- If these instances can be defined, defining instances of the base -- classes is mechanical: -- -- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 -- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 -- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1 -- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 -- ----------------------------------------------------------------------------- module Data.Functor.Classes ( -- * Liftings of Prelude classes -- ** For unary constructors Eq1(..), eq1, Ord1(..), compare1, Read1(..), readsPrec1, Show1(..), showsPrec1, -- ** For binary constructors Eq2(..), eq2, Ord2(..), compare2, Read2(..), readsPrec2, Show2(..), showsPrec2, -- * Helper functions -- $example readsData, readsUnaryWith, readsBinaryWith, showsUnaryWith, showsBinaryWith, -- ** Obsolete helpers readsUnary, readsUnary1, readsBinary1, showsUnary, showsUnary1, showsBinary1, ) where import Control.Applicative (Const(Const)) import Data.Functor.Identity (Identity(Identity)) import Data.Monoid (mappend) #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy(Proxy)) #endif import Text.Show (showListWith) import Control.Monad.Trans.Error import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Product #if MIN_VERSION_transformers(0,3,0) import Control.Applicative.Lift import Control.Applicative.Backwards import Data.Functor.Reverse #endif #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 708 import Data.Typeable # endif #endif -- | Lifting of the 'Eq' class to unary type constructors. class Eq1 f where -- | Lift an equality test through the type constructor. -- -- The function will usually be applied to an equality function, -- but the more general type ensures that the implementation uses -- it to compare elements of the first container with elements of -- the second. liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool -- | Lift the standard @('==')@ function through the type constructor. eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool eq1 = liftEq (==) -- | Lifting of the 'Ord' class to unary type constructors. class (Eq1 f) => Ord1 f where -- | Lift a 'compare' function through the type constructor. -- -- The function will usually be applied to a comparison function, -- but the more general type ensures that the implementation uses -- it to compare elements of the first container with elements of -- the second. liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering -- | Lift the standard 'compare' function through the type constructor. compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering compare1 = liftCompare compare -- | Lifting of the 'Read' class to unary type constructors. class Read1 f where -- | 'readsPrec' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument type. liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) -- | 'readList' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument type. -- The default implementation using standard list syntax is correct -- for most types. liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) -- | Read a list (using square brackets and commas), given a function -- for reading elements. readListWith :: ReadS a -> ReadS [a] readListWith rp = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) where readl s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] readl' s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] -- | Lift the standard 'readsPrec' and 'readList' functions through the -- type constructor. readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) readsPrec1 = liftReadsPrec readsPrec readList -- | Lifting of the 'Show' class to unary type constructors. class Show1 f where -- | 'showsPrec' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument type. liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS -- | 'showList' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument type. -- The default implementation using standard list syntax is correct -- for most types. liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) -- | Lift the standard 'showsPrec' and 'showList' functions through the -- type constructor. showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS showsPrec1 = liftShowsPrec showsPrec showList -- | Lifting of the 'Eq' class to binary type constructors. class Eq2 f where -- | Lift equality tests through the type constructor. -- -- The function will usually be applied to equality functions, -- but the more general type ensures that the implementation uses -- them to compare elements of the first container with elements of -- the second. liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool -- | Lift the standard @('==')@ function through the type constructor. eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool eq2 = liftEq2 (==) (==) -- | Lifting of the 'Ord' class to binary type constructors. class (Eq2 f) => Ord2 f where -- | Lift 'compare' functions through the type constructor. -- -- The function will usually be applied to comparison functions, -- but the more general type ensures that the implementation uses -- them to compare elements of the first container with elements of -- the second. liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> f a c -> f b d -> Ordering -- | Lift the standard 'compare' function through the type constructor. compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering compare2 = liftCompare2 compare compare -- | Lifting of the 'Read' class to binary type constructors. class Read2 f where -- | 'readsPrec' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument types. liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) -- | 'readList' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument types. -- The default implementation using standard list syntax is correct -- for most types. liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] liftReadList2 rp1 rl1 rp2 rl2 = readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) -- | Lift the standard 'readsPrec' function through the type constructor. readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList -- | Lifting of the 'Show' class to binary type constructors. class Show2 f where -- | 'showsPrec' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument types. liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS -- | 'showList' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument types. -- The default implementation using standard list syntax is correct -- for most types. liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS liftShowList2 sp1 sl1 sp2 sl2 = showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) -- | Lift the standard 'showsPrec' function through the type constructor. showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList -- Instances for Prelude type constructors instance Eq1 Maybe where liftEq _ Nothing Nothing = True liftEq _ Nothing (Just _) = False liftEq _ (Just _) Nothing = False liftEq eq (Just x) (Just y) = eq x y instance Ord1 Maybe where liftCompare _ Nothing Nothing = EQ liftCompare _ Nothing (Just _) = LT liftCompare _ (Just _) Nothing = GT liftCompare comp (Just x) (Just y) = comp x y instance Read1 Maybe where liftReadsPrec rp _ d = readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) `mappend` readsData (readsUnaryWith rp "Just" Just) d instance Show1 Maybe where liftShowsPrec _ _ _ Nothing = showString "Nothing" liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x instance Eq1 [] where liftEq _ [] [] = True liftEq _ [] (_:_) = False liftEq _ (_:_) [] = False liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys instance Ord1 [] where liftCompare _ [] [] = EQ liftCompare _ [] (_:_) = LT liftCompare _ (_:_) [] = GT liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys instance Read1 [] where liftReadsPrec _ rl _ = rl instance Show1 [] where liftShowsPrec _ sl _ = sl instance Eq2 (,) where liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 instance Ord2 (,) where liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = comp1 x1 x2 `mappend` comp2 y1 y2 instance Read2 (,) where liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> [((x,y), w) | ("(",s) <- lex r, (x,t) <- rp1 0 s, (",",u) <- lex t, (y,v) <- rp2 0 u, (")",w) <- lex v] instance Show2 (,) where liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' instance (Eq a) => Eq1 ((,) a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 ((,) a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 ((,) a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 ((,) a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Eq2 Either where liftEq2 e1 _ (Left x) (Left y) = e1 x y liftEq2 _ _ (Left _) (Right _) = False liftEq2 _ _ (Right _) (Left _) = False liftEq2 _ e2 (Right x) (Right y) = e2 x y instance Ord2 Either where liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y liftCompare2 _ _ (Left _) (Right _) = LT liftCompare2 _ _ (Right _) (Left _) = GT liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y instance Read2 Either where liftReadsPrec2 rp1 _ rp2 _ = readsData $ readsUnaryWith rp1 "Left" Left `mappend` readsUnaryWith rp2 "Right" Right instance Show2 Either where liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x instance (Eq a) => Eq1 (Either a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 (Either a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 (Either a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 (Either a) where liftShowsPrec = liftShowsPrec2 showsPrec showList -- Instances for other functors defined in the base package instance Eq1 Identity where liftEq eq (Identity x) (Identity y) = eq x y instance Ord1 Identity where liftCompare comp (Identity x) (Identity y) = comp x y instance Read1 Identity where liftReadsPrec rp _ = readsData $ readsUnaryWith rp "Identity" Identity instance Show1 Identity where liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x instance Eq2 Const where liftEq2 eq _ (Const x) (Const y) = eq x y instance Ord2 Const where liftCompare2 comp _ (Const x) (Const y) = comp x y instance Read2 Const where liftReadsPrec2 rp _ _ _ = readsData $ readsUnaryWith rp "Const" Const instance Show2 Const where liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x instance (Eq a) => Eq1 (Const a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 (Const a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 (Const a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 (Const a) where liftShowsPrec = liftShowsPrec2 showsPrec showList #if MIN_VERSION_base(4,7,0) instance Eq1 Proxy where liftEq _ _ _ = True instance Ord1 Proxy where liftCompare _ _ _ = EQ instance Show1 Proxy where liftShowsPrec _ _ _ _ = showString "Proxy" instance Read1 Proxy where liftReadsPrec _ _ d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) #endif -- Building blocks -- | @'readsData' p d@ is a parser for datatypes where each alternative -- begins with a data constructor. It parses the constructor and -- passes it to @p@. Parsers for various constructors can be constructed -- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with -- @mappend@ from the @Monoid@ class. readsData :: (String -> ReadS a) -> Int -> ReadS a readsData reader d = readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] -- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor -- and then parses its argument using @rp@. readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t readsUnaryWith rp name cons kw s = [(cons x,t) | kw == name, (x,t) <- rp 11 s] -- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary -- data constructor and then parses its arguments using @rp1@ and @rp2@ -- respectively. readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> String -> (a -> b -> t) -> String -> ReadS t readsBinaryWith rp1 rp2 name cons kw s = [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] -- | @'showsUnaryWith' sp n d x@ produces the string representation of a -- unary data constructor with name @n@ and argument @x@, in precedence -- context @d@. showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS showsUnaryWith sp name d x = showParen (d > 10) $ showString name . showChar ' ' . sp 11 x -- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string -- representation of a binary data constructor with name @n@ and arguments -- @x@ and @y@, in precedence context @d@. showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y -- Obsolete building blocks -- | @'readsUnary' n c n'@ matches the name of a unary data constructor -- and then parses its argument using 'readsPrec'. {-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t readsUnary name cons kw s = [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] -- | @'readsUnary1' n c n'@ matches the name of a unary data constructor -- and then parses its argument using 'readsPrec1'. {-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t readsUnary1 name cons kw s = [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] -- | @'readsBinary1' n c n'@ matches the name of a binary data constructor -- and then parses its arguments using 'readsPrec1'. {-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} readsBinary1 :: (Read1 f, Read1 g, Read a) => String -> (f a -> g a -> t) -> String -> ReadS t readsBinary1 name cons kw s = [(cons x y,u) | kw == name, (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] -- | @'showsUnary' n d x@ produces the string representation of a unary data -- constructor with name @n@ and argument @x@, in precedence context @d@. {-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} showsUnary :: (Show a) => String -> Int -> a -> ShowS showsUnary name d x = showParen (d > 10) $ showString name . showChar ' ' . showsPrec 11 x -- | @'showsUnary1' n d x@ produces the string representation of a unary data -- constructor with name @n@ and argument @x@, in precedence context @d@. {-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS showsUnary1 name d x = showParen (d > 10) $ showString name . showChar ' ' . showsPrec1 11 x -- | @'showsBinary1' n d x y@ produces the string representation of a binary -- data constructor with name @n@ and arguments @x@ and @y@, in precedence -- context @d@. {-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} showsBinary1 :: (Show1 f, Show1 g, Show a) => String -> Int -> f a -> g a -> ShowS showsBinary1 name d x y = showParen (d > 10) $ showString name . showChar ' ' . showsPrec1 11 x . showChar ' ' . showsPrec1 11 y instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y instance (Read e, Read1 m) => Read1 (ErrorT e m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show e, Show1 m) => Show1 (ErrorT e m) where liftShowsPrec sp sl d (ErrorT m) = showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1 instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1 instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where readsPrec = readsPrec1 instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where showsPrec = showsPrec1 instance (Eq1 f) => Eq1 (IdentityT f) where liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y instance (Ord1 f) => Ord1 (IdentityT f) where liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y instance (Read1 f) => Read1 (IdentityT f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT instance (Show1 f) => Show1 (IdentityT f) where liftShowsPrec sp sl d (IdentityT m) = showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1 instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1 instance (Eq1 m) => Eq1 (ListT m) where liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y instance (Ord1 m) => Ord1 (ListT m) where liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y instance (Read1 m) => Read1 (ListT m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show1 m) => Show1 (ListT m) where liftShowsPrec sp sl d (ListT m) = showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1 instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1 instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1 instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 instance (Eq1 m) => Eq1 (MaybeT m) where liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y instance (Ord1 m) => Ord1 (MaybeT m) where liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y instance (Read1 m) => Read1 (MaybeT m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show1 m) => Show1 (MaybeT m) where liftShowsPrec sp sl d (MaybeT m) = showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1 instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1 instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1 instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) = liftCompare (liftCompare2 comp compare) m1 m2 instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT where rp' = liftReadsPrec2 rp rl readsPrec readList rl' = liftReadList2 rp rl readsPrec readList instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where liftShowsPrec sp sl d (Lazy.WriterT m) = showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m where sp' = liftShowsPrec2 sp sl showsPrec showList sl' = liftShowList2 sp sl showsPrec showList instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where (==) = eq1 instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where compare = compare1 instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where readsPrec = readsPrec1 instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where showsPrec = showsPrec1 instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) = liftCompare (liftCompare2 comp compare) m1 m2 instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT where rp' = liftReadsPrec2 rp rl readsPrec readList rl' = liftReadList2 rp rl readsPrec readList instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where liftShowsPrec sp sl d (Strict.WriterT m) = showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m where sp' = liftShowsPrec2 sp sl showsPrec showList sl' = liftShowList2 sp sl showsPrec showList instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where (==) = eq1 instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where compare = compare1 instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where readsPrec = readsPrec1 instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where showsPrec = showsPrec1 instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where liftCompare comp (Compose x) (Compose y) = liftCompare (liftCompare comp) x y instance (Read1 f, Read1 g) => Read1 (Compose f g) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show1 f, Show1 g) => Show1 (Compose f g) where liftShowsPrec sp sl d (Compose x) = showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where (==) = eq1 instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where compare = compare1 instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where readsPrec = readsPrec1 instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where showsPrec = showsPrec1 instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where liftCompare comp (Pair x1 y1) (Pair x2 y2) = liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 instance (Read1 f, Read1 g) => Read1 (Product f g) where liftReadsPrec rp rl = readsData $ readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair instance (Show1 f, Show1 g) => Show1 (Product f g) where liftShowsPrec sp sl d (Pair x y) = showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) where (==) = eq1 instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where compare = compare1 instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where readsPrec = readsPrec1 instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where showsPrec = showsPrec1 instance Eq2 Constant where liftEq2 eq _ (Constant x) (Constant y) = eq x y instance Ord2 Constant where liftCompare2 comp _ (Constant x) (Constant y) = comp x y instance Read2 Constant where liftReadsPrec2 rp _ _ _ = readsData $ readsUnaryWith rp "Constant" Constant instance Show2 Constant where liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x instance (Eq a) => Eq1 (Constant a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 (Constant a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 (Constant a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 (Constant a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Eq a => Eq (Constant a b) where Constant a == Constant b = a == b instance Ord a => Ord (Constant a b) where compare (Constant a) (Constant b) = compare a b instance (Read a) => Read (Constant a b) where readsPrec = readsData $ readsUnaryWith readsPrec "Constant" Constant instance (Show a) => Show (Constant a b) where showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x instance Show a => Show (Identity a) where showsPrec d (Identity a) = showParen (d > 10) $ showString "Identity " . showsPrec 11 a instance Read a => Read (Identity a) where readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s]) instance Eq a => Eq (Identity a) where Identity a == Identity b = a == b instance Ord a => Ord (Identity a) where compare (Identity a) (Identity b) = compare a b #if MIN_VERSION_transformers(0,3,0) instance (Eq1 f) => Eq1 (Lift f) where liftEq eq (Pure x1) (Pure x2) = eq x1 x2 liftEq _ (Pure _) (Other _) = False liftEq _ (Other _) (Pure _) = False liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 instance (Ord1 f) => Ord1 (Lift f) where liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 liftCompare _ (Pure _) (Other _) = LT liftCompare _ (Other _) (Pure _) = GT liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 instance (Read1 f) => Read1 (Lift f) where liftReadsPrec rp rl = readsData $ readsUnaryWith rp "Pure" Pure `mappend` readsUnaryWith (liftReadsPrec rp rl) "Other" Other instance (Show1 f) => Show1 (Lift f) where liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x liftShowsPrec sp sl d (Other y) = showsUnaryWith (liftShowsPrec sp sl) "Other" d y instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 instance (Eq1 f) => Eq1 (Backwards f) where liftEq eq (Backwards x) (Backwards y) = liftEq eq x y instance (Ord1 f) => Ord1 (Backwards f) where liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y instance (Read1 f) => Read1 (Backwards f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards instance (Show1 f) => Show1 (Backwards f) where liftShowsPrec sp sl d (Backwards x) = showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 instance (Eq1 f) => Eq1 (Reverse f) where liftEq eq (Reverse x) (Reverse y) = liftEq eq x y instance (Ord1 f) => Ord1 (Reverse f) where liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y instance (Read1 f) => Read1 (Reverse f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse instance (Show1 f) => Show1 (Reverse f) where liftShowsPrec sp sl d (Reverse x) = showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 #endif #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable Eq1 deriving instance Typeable Eq2 deriving instance Typeable Ord1 deriving instance Typeable Ord2 deriving instance Typeable Read1 deriving instance Typeable Read2 deriving instance Typeable Show1 deriving instance Typeable Show2 # endif #endif {- $example These functions can be used to assemble 'Read' and 'Show' instances for new algebraic types. For example, given the definition > data T f a = Zero a | One (f a) | Two a (f a) a standard 'Read1' instance may be defined as > instance (Read1 f) => Read1 (T f) where > liftReadsPrec rp rl = readsData $ > readsUnaryWith rp "Zero" Zero `mappend` > readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` > readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two and the corresponding 'Show1' instance as > instance (Show1 f) => Show1 (T f) where > liftShowsPrec sp _ d (Zero x) = > showsUnaryWith sp "Zero" d x > liftShowsPrec sp sl d (One x) = > showsUnaryWith (liftShowsPrec sp sl) "One" d x > liftShowsPrec sp sl d (Two x y) = > showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y -} transformers-compat-0.6.5/0.3/Data/Functor/Sum.hs0000644000000000000000000001026407346545000017615 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} # if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif # if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DataKinds #-} # endif #endif -- | -- Module : Data.Functor.Sum -- Copyright : (c) Ross Paterson 2014 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- Sums, lifted to functors. module Data.Functor.Sum ( Sum(..), ) where import Control.Applicative import Data.Foldable (Foldable(foldMap)) import Data.Functor.Classes import Data.Monoid (mappend) import Data.Traversable (Traversable(traverse)) #ifndef HASKELL98 # ifdef GENERIC_DERIVING import Generics.Deriving.Base # elif __GLASGOW_HASKELL__ >= 702 import GHC.Generics # endif # if __GLASGOW_HASKELL__ >= 708 import Data.Data # endif #endif -- | Lifted sum of functors. data Sum f g a = InL (f a) | InR (g a) #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) -- Generic(1) instances for Sum instance Generic (Sum f g a) where type Rep (Sum f g a) = D1 MDSum (C1 MCInL (S1 NoSelector (Rec0 (f a))) :+: C1 MCInR (S1 NoSelector (Rec0 (g a)))) from (InL f) = M1 (L1 (M1 (M1 (K1 f)))) from (InR g) = M1 (R1 (M1 (M1 (K1 g)))) to (M1 (L1 (M1 (M1 (K1 f))))) = InL f to (M1 (R1 (M1 (M1 (K1 g))))) = InR g instance Generic1 (Sum f g) where type Rep1 (Sum f g) = D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f)) :+: C1 MCInR (S1 NoSelector (Rec1 g))) from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f)))) from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g)))) to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f) to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) data MDSum data MCInL data MCInR instance Datatype MDSum where datatypeName _ = "Sum" moduleName _ = "Data.Functor.Sum" instance Constructor MCInL where conName _ = "InL" instance Constructor MCInR where conName _ = "InR" # endif # if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable Sum deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) # endif #endif instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 liftEq _ (InL _) (InR _) = False liftEq _ (InR _) (InL _) = False liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 liftCompare _ (InL _) (InR _) = LT liftCompare _ (InR _) (InL _) = GT liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 instance (Read1 f, Read1 g) => Read1 (Sum f g) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` readsUnaryWith (liftReadsPrec rp rl) "InR" InR instance (Show1 f, Show1 g) => Show1 (Sum f g) where liftShowsPrec sp sl d (InL x) = showsUnaryWith (liftShowsPrec sp sl) "InL" d x liftShowsPrec sp sl d (InR y) = showsUnaryWith (liftShowsPrec sp sl) "InR" d y instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where (==) = eq1 instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where compare = compare1 instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where readsPrec = readsPrec1 instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where showsPrec = showsPrec1 instance (Functor f, Functor g) => Functor (Sum f g) where fmap f (InL x) = InL (fmap f x) fmap f (InR y) = InR (fmap f y) instance (Foldable f, Foldable g) => Foldable (Sum f g) where foldMap f (InL x) = foldMap f x foldMap f (InR y) = foldMap f y instance (Traversable f, Traversable g) => Traversable (Sum f g) where traverse f (InL x) = InL <$> traverse f x traverse f (InR y) = InR <$> traverse f y transformers-compat-0.6.5/0.5/Control/Monad/Trans/0000755000000000000000000000000007346545000017770 5ustar0000000000000000transformers-compat-0.6.5/0.5/Control/Monad/Trans/Accum.hs0000644000000000000000000002371507346545000021364 0ustar0000000000000000{-# 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 import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.Signatures #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif #if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 import Data.Typeable #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 #-} instance (Monoid w, Functor m, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where fail msg = AccumT $ const (Fail.fail msg) {-# INLINE fail #-} instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where mzero = AccumT $ const mzero {-# INLINE mzero #-} m `mplus` n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w {-# INLINE mplus #-} instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where mfix m = AccumT $ \ w -> mfix $ \ ~(a, _) -> runAccumT (m a) w {-# INLINE mfix #-} instance (Monoid w) => MonadTrans (AccumT w) where lift m = AccumT $ const $ do a <- m return (a, mempty) {-# INLINE lift #-} instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where liftIO = lift . liftIO {-# INLINE liftIO #-} #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 #-} transformers-compat-0.6.5/0.5/Control/Monad/Trans/Select.hs0000644000000000000000000001246407346545000021552 0ustar0000000000000000{-# 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 import qualified Control.Monad.Fail as Fail 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 (>>=) #-} instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where fail msg = lift (Fail.fail msg) {-# INLINE fail #-} instance (MonadPlus m) => MonadPlus (SelectT r m) where mzero = SelectT (const mzero) {-# INLINE mzero #-} SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k {-# INLINE mplus #-} instance MonadTrans (SelectT r) where lift = SelectT . const {-# INLINE lift #-} instance (MonadIO m) => MonadIO (SelectT r m) where liftIO = lift . liftIO {-# INLINE liftIO #-} #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 transformers-compat-0.6.5/CHANGELOG.markdown0000755000000000000000000003122107346545000016756 0ustar00000000000000000.6.5 [2019.05.11] ------------------ * Ensure that the backported `MonadFail` instance for `ExceptT` is available when built against `transformers-0.4.*`. 0.6.4 [2019.04.01] ------------------ * Use more conservative CPP to guard the backported `MonadFix` instance for `ListT`. 0.6.3 [2019.04.01] ------------------ * Backport changes from `transformers-0.5.6.*`: * Backport the `MonadFix` instance for `ListT` in `Control.Monad.Trans.Instances`. * Generalize the type of `except` in `Control.Monad.Trans.Except`. * Backport `MonadFail` instances for `AccumT`, `Reverse`, and `SelectT` on pre-8.0 versions of GHC by depending on the `fail` package if necessary. * Backport `MonadFail` instances for monad transformer types in `Control.Monad.Trans.Instances`. 0.6.2 ----- * `transformers-compat` now uses automatic flags instead of manual ones. This has a number of benefits: * There is no need for making several simultaneous releases to support each flag combination. * As a result, the `cabal-install` constraint solver should have a much easier time figuring out install-plans involving `transformers-compat`. Due to old `cabal-install` bugs, `cabal-install-1.16` and older may have a harder time installing this package, so it is recommended that you use `cabal-install-1.18` or later. (Or, if you must use `cabal-install-1.16` or older, installing `transformers-compat` with the appropriate flags should help.) 0.6.1.6 ------- * Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version. This release is configured with none of `-ftwo`, `-fthree`, `-ffour`, or `-ffive` (which works with `transformers-0.5.3` and above). 0.6.1.5 ------- * Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version. This release is configured with `-ffive` (which works with `transformers-0.5` up until, but not including, `transformers-0.5.3`). 0.6.1.4 ------- * Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version. This release is configured with `-ffour` (which works with the `transformers-0.4` series). 0.6.1.3 ------- * Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version. This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.6.1.2 ------- * Each of versions 0.6.1.2–0.6.1.6 is a 0.6.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6.1 release notes describe the changes in this version. This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.6.1 ----- * Fix an oversight in which the `Control.Monad.Trans.Accum` and `Control.Monad.Trans.Select` modules were not backported when built with the `-ffour` flag. 0.6.0.6 ------- * Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version. This release is configured with none of `-ftwo`, `-fthree`, `-ffour`, or `-ffive` (which works with `transformers-0.5.3` and above). 0.6.0.5 ------- * Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version. This release is configured with `-ffive` (which works with `transformers-0.5` up until, but not including, `transformers-0.5.3`). 0.6.0.4 ------- * Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version. This release is configured with `-ffour` (which works with the `transformers-0.4` series). 0.6.0.3 ------- * Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version. This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.6.0.2 ------- * Each of versions 0.6.0.2–0.6.0.6 is a 0.6 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.6 release notes describe the changes in this version. This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.6 --- * Introduce the `Data.Functor.Classes.Generic` module, which provides functions that can generically implement methods in the `Eq1`, `Ord1`, `Read1`, and `Show1` classes (without the usual boilerplate involved). * Introduce the `generic-deriving` flag. When enabled, `transformers-compat` will depend on the `generic-deriving` library on older versions of GHC to backport `GHC.Generics` support for `Generic` instances and the machinery in `Data.Functor.Classes.Generic`. * Some instances were present in `Data.Functor.Sum` but not in `Control.Monad.Trans.Instances` (e.g., the `Generic`, `Typeable`, and `Data` instances for `Sum`). This has been fixed. * Backport changes from `transformers-0.5.5`: * Backport the `Semigroup` instance for `Constant` * Add `mapSelect` and `mapSelectT` * Define `selectToContT` (and deprecate `selectToCont` in favor of that) * Define some explicit `(*>)` definitions to avoid space leaks * Backport changes from `transformers-0.5.4` (i.e., add `Bifoldable` and `Bitraversable` instances for `Data.Functor.Constant`) * Backport changes from `transformers-0.5.3`: * Backport the `Control.Monad.Trans.Accum` and `Control.Monad.Trans.Select` modules * Backport the `eitherToErrors` and `elimLift` functions to `Control.Applicative.Lift` * Backport `Bits`, `FiniteBits`, `IsString`, `Num`, `Real`, `Integral`, `Fractional`, `Floating`, `RealFrac`, and `RealFloat` instances for `Data.Functor.Identity` * Backport `Monad`, `MonadFail`, and `MonadPlus` instances for `Data.Functor.Reverse` * Backport `Eq1`, `Ord1`, `Read1`, and `Show1` instances for `Data.Proxy` * Backport changes from `transformers-0.5.2` (i.e., add more `INLINE` annotations) * Backport changes from `transformers-0.5.1` (i.e., add `Bounded`, `Enum`, `Ix`, and `Storable` instances for `Identity`) 0.5.1.4 ------- * Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version. This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above). 0.5.1.3 ------- * Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version. This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.5.1.2 ------- * Each of versions 0.5.1.2–0.5.1.4 is a 0.5.1 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5.1 release notes describe the changes in this version. This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.5.1 ----- * Fix a bug in which `PolyKinds` was enabled on GHC 7.4, resulting in interface file bugs on that version of GHC. 0.5.0.4 ------- * Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version. This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above). 0.5.0.3 ------- * Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version. This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.5.0.2 ------- * Each of versions 0.5.0.2–0.5.0.4 is a 0.5 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.5 release notes describe the changes in this version. This release is configured with `-ftwo` (which works with the `transformers-0.2` series). 0.5 --- * Update `transformers-compat` to incorporate changes from the `transformers-0.5` series. These changes include: * The `Data.Functor.Classes` module was completely redesigned. * Modules now have `Safe` or `Trustworthy` annotations. * Data types and type synonyms are poly-kinded when possible. * Add `Control.Monad.Trans.Instances`, a module of orphan instances that mimic instances available in later versions of `transformers`. 0.4.0.4 ------- * Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version. This release is configured with neither `-ftwo` nor `-fthree` (which works with `transformers-0.4` and above). 0.4.0.3 ------- * Each of versions 0.4.0.2–0.4.0.4 is a 0.4 build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. The 0.4 release notes describe the changes in this version. This release is configured with `-fthree` (which works with the `transformers-0.3` series). 0.4.0.2 ------- * Each of 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 --- * Added support for the missing `ExceptT` instances from `mtl`. This was not done lightly. While this means that by default incurring a dependency on `transformers-compat` drags in `mtl` when you are using an old `transformers`, it means that users do not have to orphan these instances and permits wider adoption of `ExceptT`. If you absolutely can't stand `mtl` and really want this package to build as valid `Haskell98`, then you can use `cabal install transformers-compat -f-mtl` to avoid incurring the dependency to get these instances. However, that is effectively an unsupported configuration. 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 ------- * 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 ----- * This release was a failed (or at least, only partially successful) attempt to fix build problems caused by the cabal backtracker. 0.3.1 ----- * `transformers 0.4.1` compatibility 0.3 --- * Added the instances for `Data.Functor.Classes` from `transformers 0.4` * Switched `Control.Applicative.Backwards` and `Data.Functor.Reverse` to the split constructor/accessor style from `transformers 0.4`. 0.2 --- * Added the new types and classes from `transformers 0.4` 0.1.1.1 ------- * Wrote a better synopsis 0.1.1 ----- * Updated to trick `cabal` into building an empty `libHStransformers-compat-0.1.a` on GHC 7.6. 0.1 --- * Repository initialized by pulling the `transformers-0.2` compatibility layer out of `lens`. transformers-compat-0.6.5/HLint.hs0000755000000000000000000000003707346545000015276 0ustar0000000000000000ignore "Warning: Avoid lambda" transformers-compat-0.6.5/LICENSE0000644000000000000000000000266007346545000014732 0ustar0000000000000000Copyright 2012-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. transformers-compat-0.6.5/README.markdown0000755000000000000000000000214607346545000016430 0ustar0000000000000000transformers-compat =================== [![Hackage](https://img.shields.io/hackage/v/transformers-compat.svg)](https://hackage.haskell.org/package/transformers-compat) [![Build Status](https://secure.travis-ci.org/ekmett/transformers-compat.png?branch=master)](http://travis-ci.org/ekmett/transformers-compat) This provides a thin compatibility shim on top of transformers-0.2 to add the types that were added in transformers-0.3. This enables users to maintain haskell-platform compatibility, while still gaining access ot the new functionality. Related packages ---------------- The `writer-cps-transformers` package backports the `Control.Monad.Trans.{RWS,Writer}.CPS` modules that were introduced in `transformers-0.5.6.0`. There are also a variety of companion packages which backport orphan instances for these types. One example is `writer-cps-mtl`, which backports instances of type classes from the `mtl` library. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett transformers-compat-0.6.5/Setup.lhs0000644000000000000000000000016507346545000015533 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain transformers-compat-0.6.5/config0000755000000000000000000000120607346545000015113 0ustar0000000000000000-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix -- -- This is particularly useful for travis-ci to get it to stop complaining -- about a broken build when everything is still correct on our end. -- -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead -- -- To enable this, uncomment the before_script in .travis.yml remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive remote-repo-cache: ~/.cabal/packages world-file: ~/.cabal/world build-summary: ~/.cabal/logs/build.log remote-build-reporting: anonymous install-dirs user install-dirs global transformers-compat-0.6.5/generics/Data/Functor/Classes/0000755000000000000000000000000007346545000021406 5ustar0000000000000000transformers-compat-0.6.5/generics/Data/Functor/Classes/Generic.hs0000644000000000000000000000442707346545000023325 0ustar0000000000000000{-# 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 @ -} transformers-compat-0.6.5/generics/Data/Functor/Classes/Generic/0000755000000000000000000000000007346545000022762 5ustar0000000000000000transformers-compat-0.6.5/generics/Data/Functor/Classes/Generic/Internal.hs0000644000000000000000000007230607346545000025102 0ustar0000000000000000{-# 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 transformers-compat-0.6.5/src/Control/Monad/Trans/0000755000000000000000000000000007346545000020255 5ustar0000000000000000transformers-compat-0.6.5/src/Control/Monad/Trans/Instances.hs0000644000000000000000000006402407346545000022546 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} # if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif # if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DataKinds #-} # endif #endif {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Instances -- Copyright : (C) 2012-16 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Backports orphan instances which are not provided by other modules in -- @transformers-compat@. ---------------------------------------------------------------------------- module Control.Monad.Trans.Instances () where #ifndef MIN_VERSION_base #define MIN_VERSION_base(a,b,c) 1 #endif #ifndef MIN_VERSION_transformers #define MIN_VERSION_transformers(a,b,c) 1 #endif import Control.Applicative.Backwards (Backwards(..)) import Control.Applicative.Lift (Lift(..)) import qualified Control.Monad.Fail as Fail (MonadFail(..)) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Accum (AccumT(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Cont (ContT(..)) import Control.Monad.Trans.Error (Error(..), ErrorT(..)) import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans.List (ListT(..), mapListT) import Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..)) import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Select (SelectT(..)) import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..)) import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..)) import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..)) import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT(..)) import Data.Functor.Classes import Data.Functor.Compose (Compose(..)) import Data.Functor.Constant (Constant(..)) import Data.Functor.Identity (Identity(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Reverse (Reverse(..)) import Data.Functor.Sum (Sum(..)) import Control.Applicative import Control.Arrow (Arrow((***))) import Control.Monad (MonadPlus(..), liftM) import Control.Monad.Fix (MonadFix(..)) import 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 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 # ifdef GENERIC_DERIVING import Generics.Deriving.Base # elif __GLASGOW_HASKELL__ >= 702 import GHC.Generics # endif #endif #if !(MIN_VERSION_transformers(0,3,0)) -- Foldable/Traversable instances instance (Foldable f) => Foldable (ErrorT e f) where foldMap f (ErrorT a) = foldMap (either (const mempty) f) a instance (Traversable f) => Traversable (ErrorT e f) where traverse f (ErrorT a) = ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a instance (Foldable f) => Foldable (IdentityT f) where foldMap f (IdentityT a) = foldMap f a instance (Traversable f) => Traversable (IdentityT f) where traverse f (IdentityT a) = IdentityT <$> traverse f a instance (Foldable f) => Foldable (ListT f) where foldMap f (ListT a) = foldMap (foldMap f) a instance (Traversable f) => Traversable (ListT f) where traverse f (ListT a) = ListT <$> traverse (traverse f) a instance (Foldable f) => Foldable (MaybeT f) where foldMap f (MaybeT a) = foldMap (foldMap f) a instance (Traversable f) => Traversable (MaybeT f) where traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a instance (Foldable f) => Foldable (Lazy.WriterT w f) where foldMap f = foldMap (f . fst) . Lazy.runWriterT instance (Traversable f) => Traversable (Lazy.WriterT w f) where traverse f = fmap Lazy.WriterT . traverse f' . Lazy.runWriterT where f' (a, b) = fmap (\ c -> (c, b)) (f a) instance (Foldable f) => Foldable (Strict.WriterT w f) where foldMap f = foldMap (f . fst) . Strict.runWriterT instance (Traversable f) => Traversable (Strict.WriterT w f) where traverse f = fmap Strict.WriterT . traverse f' . Strict.runWriterT where f' (a, b) = fmap (\ c -> (c, b)) (f a) -- MonadFix instances for IdentityT and MaybeT instance (MonadFix m) => MonadFix (IdentityT m) where mfix f = IdentityT (mfix (runIdentityT . f)) instance (MonadFix m) => MonadFix (MaybeT m) where mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb)) where bomb = error "mfix (MaybeT): inner computation returned Nothing" # if !(MIN_VERSION_base(4,9,0)) -- Monad instances for Product instance (Monad f, Monad g) => Monad (Product f g) where return x = Pair (return x) (return x) Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) where fstP (Pair a _) = a sndP (Pair _ b) = b instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where mzero = Pair mzero mzero Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) where fstP (Pair a _) = a sndP (Pair _ b) = b # endif #endif #if !(MIN_VERSION_transformers(0,4,0)) -- Alternative IO instance # if !(MIN_VERSION_base(4,9,0)) -- The version bounds of transformers prior to 0.4.0.0 should prevent this -- instance from being compiled on base-4.8.0.0 and later, but we'll put -- a check here just to be safe. instance Alternative IO where empty = mzero (<|>) = mplus # endif #endif #if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,4,3)) -- transformers-0.4-specific Eq1, Ord1, Read1, and Show1 instances for Const instance (Eq a) => Eq1 (Const a) where eq1 (Const x) (Const y) = x == y instance (Ord a) => Ord1 (Const a) where compare1 (Const x) (Const y) = compare x y instance (Read a) => Read1 (Const a) where readsPrec1 = readsData $ readsUnary "Const" Const instance (Show a) => Show1 (Const a) where showsPrec1 d (Const x) = showsUnary "Const" d x #endif #if !(MIN_VERSION_transformers(0,5,0)) \ || (MIN_VERSION_transformers(0,5,0) && !(MIN_VERSION_base(4,9,0))) -- MonadFail instances instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where fail msg = ContT $ \ _ -> Fail.fail msg {-# INLINE fail #-} instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where fail msg = ErrorT $ return (Left (strMsg msg)) instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where fail msg = IdentityT $ Fail.fail msg {-# INLINE fail #-} instance (Monad m) => Fail.MonadFail (ListT m) where fail _ = ListT $ return [] {-# INLINE fail #-} instance (Monad m) => Fail.MonadFail (MaybeT m) where fail _ = MaybeT (return Nothing) {-# INLINE fail #-} instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where fail msg = lift (Fail.fail msg) {-# INLINE fail #-} instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.RWST r w s m) where fail msg = Lazy.RWST $ \ _ _ -> Fail.fail msg {-# INLINE fail #-} instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.RWST r w s m) where fail msg = Strict.RWST $ \ _ _ -> Fail.fail msg {-# INLINE fail #-} instance (Fail.MonadFail m) => Fail.MonadFail (Lazy.StateT s m) where fail str = Lazy.StateT $ \ _ -> Fail.fail str {-# INLINE fail #-} instance (Fail.MonadFail m) => Fail.MonadFail (Strict.StateT s m) where fail str = Strict.StateT $ \ _ -> Fail.fail str {-# INLINE fail #-} instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.WriterT w m) where fail msg = Lazy.WriterT $ Fail.fail msg {-# INLINE fail #-} instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.WriterT w m) where fail msg = Strict.WriterT $ Fail.fail msg {-# INLINE fail #-} # if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_base(4,9,0)) instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where fail = ExceptT . Fail.fail {-# INLINE fail #-} # endif # if MIN_VERSION_transformers(0,5,3) && !(MIN_VERSION_base(4,9,0)) instance (Monoid w, Functor m, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where fail msg = AccumT $ const (Fail.fail msg) {-# INLINE fail #-} instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where fail msg = lift (Fail.fail msg) {-# INLINE fail #-} # endif #endif #if !(MIN_VERSION_transformers(0,5,0)) -- Monoid Constant instance instance (Monoid a) => Monoid (Constant a b) where mempty = Constant mempty Constant x `mappend` Constant y = Constant (x `mappend` y) -- MonadZip instances # if MIN_VERSION_base(4,4,0) instance (MonadZip m) => MonadZip (IdentityT m) where mzipWith f (IdentityT a) (IdentityT b) = IdentityT (mzipWith f a b) instance (MonadZip m) => MonadZip (ListT m) where mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b instance (MonadZip m) => MonadZip (MaybeT m) where mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b instance (MonadZip m) => MonadZip (ReaderT r m) where mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a -> mzipWith f (m a) (n a) instance (Monoid w, MonadZip m) => MonadZip (Lazy.WriterT w m) where mzipWith f (Lazy.WriterT x) (Lazy.WriterT y) = Lazy.WriterT $ mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y instance (Monoid w, MonadZip m) => MonadZip (Strict.WriterT w m) where mzipWith f (Strict.WriterT x) (Strict.WriterT y) = Strict.WriterT $ mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y # if !(MIN_VERSION_base(4,8,0)) instance MonadZip Identity where mzipWith f (Identity x) (Identity y) = Identity (f x y) munzip (Identity (a, b)) = (Identity a, Identity b) # endif # if !(MIN_VERSION_base(4,9,0)) instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) # endif # endif # if MIN_VERSION_base(4,8,0) -- Bifunctor Constant instance instance Bifunctor Constant where first f (Constant x) = Constant (f x) second _ (Constant x) = Constant x # else -- Monoid Identity instance instance (Monoid a) => Monoid (Identity a) where mempty = Identity mempty mappend (Identity x) (Identity y) = Identity (mappend x y) # endif # ifndef HASKELL98 -- Typeable instances # if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 deriving instance Typeable Backwards deriving instance Typeable Constant deriving instance Typeable ContT deriving instance Typeable ErrorT deriving instance Typeable IdentityT deriving instance Typeable Lift deriving instance Typeable ListT deriving instance Typeable MaybeT deriving instance Typeable MonadTrans deriving instance Typeable Lazy.RWST deriving instance Typeable Strict.RWST deriving instance Typeable ReaderT deriving instance Typeable Reverse deriving instance Typeable Lazy.StateT deriving instance Typeable Strict.StateT # if !(MIN_VERSION_base(4,9,0)) deriving instance Typeable Compose deriving instance Typeable MonadIO deriving instance Typeable Product # endif # endif -- Identity instances # if !(MIN_VERSION_base(4,8,0)) deriving instance Typeable1 Identity deriving instance Data a => Data (Identity a) # if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable 'Identity # endif # endif # if !(MIN_VERSION_base(4,9,0)) # if __GLASGOW_HASKELL__ >= 708 -- Data instances for Compose and Product deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) => Data (Product (f :: * -> *) (g :: * -> *) (a :: *)) # if MIN_VERSION_transformers(0,4,0) -- Typeable/Data instances for Sum -- These are also present in Data.Functor.Sum in transformers-compat, but only -- these are reachable if using @transformers-0.4.0.0@ deriving instance Typeable Sum deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) # endif # endif # endif # endif #endif #if !(MIN_VERSION_transformers(0,5,1)) # if !(MIN_VERSION_base(4,8,0)) instance (Bounded a) => Bounded (Identity a) where minBound = Identity minBound maxBound = Identity maxBound instance (Enum a) => Enum (Identity a) where succ (Identity x) = Identity (succ x) pred (Identity x) = Identity (pred x) toEnum i = Identity (toEnum i) fromEnum (Identity x) = fromEnum x enumFrom (Identity x) = map Identity (enumFrom x) enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y) enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y) enumFromThenTo (Identity x) (Identity y) (Identity z) = map Identity (enumFromThenTo x y z) instance (Ix a) => Ix (Identity a) where range (Identity x, Identity y) = map Identity (range (x, y)) index (Identity x, Identity y) (Identity i) = index (x, y) i inRange (Identity x, Identity y) (Identity e) = inRange (x, y) e rangeSize (Identity x, Identity y) = rangeSize (x, y) instance (Storable a) => Storable (Identity a) where sizeOf (Identity x) = sizeOf x alignment (Identity x) = alignment x peekElemOff p i = fmap Identity (peekElemOff (castPtr p) i) pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x peekByteOff p i = fmap Identity (peekByteOff p i) pokeByteOff p i (Identity x) = pokeByteOff p i x peek p = fmap runIdentity (peek (castPtr p)) poke p (Identity x) = poke (castPtr p) x # endif #endif #if !(MIN_VERSION_transformers(0,5,3)) # if !(MIN_VERSION_base(4,9,0)) # if MIN_VERSION_base(4,7,0) -- Data.Proxy # if defined(TRANSFORMERS_FOUR) instance Eq1 Proxy where eq1 _ _ = True instance Ord1 Proxy where compare1 _ _ = EQ instance Show1 Proxy where showsPrec1 _ _ = showString "Proxy" instance Read1 Proxy where readsPrec1 d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) # elif MIN_VERSION_transformers(0,5,0) instance Eq1 Proxy where liftEq _ _ _ = True instance Ord1 Proxy where liftCompare _ _ _ = EQ instance Show1 Proxy where liftShowsPrec _ _ _ _ = showString "Proxy" instance Read1 Proxy where liftReadsPrec _ _ d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) # endif # endif # endif # if !(MIN_VERSION_base(4,8,0)) -- Data.Functor.Identity instance (Bits a) => Bits (Identity a) where Identity x .&. Identity y = Identity (x .&. y) Identity x .|. Identity y = Identity (x .|. y) xor (Identity x) (Identity y) = Identity (xor x y) complement (Identity x) = Identity (complement x) shift (Identity x) i = Identity (shift x i) rotate (Identity x) i = Identity (rotate x i) setBit (Identity x) i = Identity (setBit x i) clearBit (Identity x) i = Identity (clearBit x i) shiftL (Identity x) i = Identity (shiftL x i) shiftR (Identity x) i = Identity (shiftR x i) rotateL (Identity x) i = Identity (rotateL x i) rotateR (Identity x) i = Identity (rotateR x i) testBit (Identity x) i = testBit x i bitSize (Identity x) = bitSize x isSigned (Identity x) = isSigned x bit i = Identity (bit i) # if MIN_VERSION_base(4,5,0) unsafeShiftL (Identity x) i = Identity (unsafeShiftL x i) unsafeShiftR (Identity x) i = Identity (unsafeShiftR x i) popCount (Identity x) = popCount x # endif # if MIN_VERSION_base(4,7,0) zeroBits = Identity zeroBits bitSizeMaybe (Identity x) = bitSizeMaybe x # endif # if MIN_VERSION_base(4,7,0) instance (FiniteBits a) => FiniteBits (Identity a) where finiteBitSize (Identity x) = finiteBitSize x # endif instance (Floating a) => Floating (Identity a) where pi = Identity pi exp (Identity x) = Identity (exp x) log (Identity x) = Identity (log x) sqrt (Identity x) = Identity (sqrt x) sin (Identity x) = Identity (sin x) cos (Identity x) = Identity (cos x) tan (Identity x) = Identity (tan x) asin (Identity x) = Identity (asin x) acos (Identity x) = Identity (acos x) atan (Identity x) = Identity (atan x) sinh (Identity x) = Identity (sinh x) cosh (Identity x) = Identity (cosh x) tanh (Identity x) = Identity (tanh x) asinh (Identity x) = Identity (asinh x) acosh (Identity x) = Identity (acosh x) atanh (Identity x) = Identity (atanh x) Identity x ** Identity y = Identity (x ** y) logBase (Identity x) (Identity y) = Identity (logBase x y) instance (Fractional a) => Fractional (Identity a) where Identity x / Identity y = Identity (x / y) recip (Identity x) = Identity (recip x) fromRational r = Identity (fromRational r) instance (IsString a) => IsString (Identity a) where fromString s = Identity (fromString s) instance (Integral a) => Integral (Identity a) where quot (Identity x) (Identity y) = Identity (quot x y) rem (Identity x) (Identity y) = Identity (rem x y) div (Identity x) (Identity y) = Identity (div x y) mod (Identity x) (Identity y) = Identity (mod x y) quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y) divMod (Identity x) (Identity y) = (Identity *** Identity) (divMod x y) toInteger (Identity x) = toInteger x instance (Num a) => Num (Identity a) where Identity x + Identity y = Identity (x + y) Identity x - Identity y = Identity (x - y) Identity x * Identity y = Identity (x * y) negate (Identity x) = Identity (negate x) abs (Identity x) = Identity (abs x) signum (Identity x) = Identity (signum x) fromInteger n = Identity (fromInteger n) instance (Real a) => Real (Identity a) where toRational (Identity x) = toRational x instance (RealFloat a) => RealFloat (Identity a) where floatRadix (Identity x) = floatRadix x floatDigits (Identity x) = floatDigits x floatRange (Identity x) = floatRange x decodeFloat (Identity x) = decodeFloat x exponent (Identity x) = exponent x isNaN (Identity x) = isNaN x isInfinite (Identity x) = isInfinite x isDenormalized (Identity x) = isDenormalized x isNegativeZero (Identity x) = isNegativeZero x isIEEE (Identity x) = isIEEE x significand (Identity x) = significand (Identity x) scaleFloat s (Identity x) = Identity (scaleFloat s x) encodeFloat m n = Identity (encodeFloat m n) atan2 (Identity x) (Identity y) = Identity (atan2 x y) instance (RealFrac a) => RealFrac (Identity a) where properFraction (Identity x) = (id *** Identity) (properFraction x) truncate (Identity x) = truncate x round (Identity x) = round x ceiling (Identity x) = ceiling x floor (Identity x) = floor x # endif # if MIN_VERSION_transformers(0,3,0) -- Data.Functor.Reverse instance (Monad m) => Monad (Reverse m) where return a = Reverse (return a) {-# INLINE return #-} m >>= f = Reverse (getReverse m >>= getReverse . f) {-# INLINE (>>=) #-} fail msg = Reverse (fail msg) {-# INLINE fail #-} instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where fail msg = Reverse (Fail.fail msg) {-# INLINE fail #-} instance (MonadPlus m) => MonadPlus (Reverse m) where mzero = Reverse mzero {-# INLINE mzero #-} Reverse x `mplus` Reverse y = Reverse (x `mplus` y) {-# INLINE mplus #-} # endif #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 instance (MonadFix m) => MonadFix (ListT m) where mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of [] -> return [] x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f))) {-# INLINE mfix #-} #endif -- Generic(1) instances #ifndef HASKELL98 # if (!(MIN_VERSION_transformers(0,5,0)) && (__GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING))) \ || (MIN_VERSION_transformers(0,5,0) && __GLASGOW_HASKELL__ < 702 && defined(GENERIC_DERIVING)) # if !(MIN_VERSION_base(4,8,0)) instance Generic (Identity a) where type Rep (Identity a) = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity (Rec0 a))) from (Identity x) = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = Identity x instance Generic1 Identity where type Rep1 Identity = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity Par1)) from1 (Identity x) = M1 (M1 (M1 (Par1 x))) to1 (M1 (M1 (M1 x))) = Identity (unPar1 x) data MDIdentity data MCIdentity data MSIdentity instance Datatype MDIdentity where datatypeName _ = "Identity" moduleName _ = "Data.Functor.Identity" # if __GLASGOW_HASKELL__ >= 708 isNewtype _ = True # endif instance Constructor MCIdentity where conName _ = "Identity" conIsRecord _ = True instance Selector MSIdentity where selName _ = "runIdentity" # endif # if !(MIN_VERSION_base(4,9,0)) -- Generic(1) instances for Compose instance Generic (Compose f g a) where type Rep (Compose f g a) = D1 MDCompose (C1 MCCompose (S1 MSCompose (Rec0 (f (g a))))) from (Compose x) = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = Compose x instance Functor f => Generic1 (Compose f g) where type Rep1 (Compose f g) = D1 MDCompose (C1 MCCompose (S1 MSCompose (f :.: Rec1 g))) from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x)))) to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x)) data MDCompose data MCCompose data MSCompose instance Datatype MDCompose where datatypeName _ = "Compose" moduleName _ = "Data.Functor.Compose" # if __GLASGOW_HASKELL__ >= 708 isNewtype _ = True # endif instance Constructor MCCompose where conName _ = "Compose" conIsRecord _ = True instance Selector MSCompose where selName _ = "getCompose" -- Generic(1) instances for Product instance Generic (Product f g a) where type Rep (Product f g a) = D1 MDProduct (C1 MCPair (S1 NoSelector (Rec0 (f a)) :*: S1 NoSelector (Rec0 (g a)))) from (Pair f g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g))) to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = Pair f g instance Generic1 (Product f g) where type Rep1 (Product f g) = D1 MDProduct (C1 MCPair (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g))) from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g) data MDProduct data MCPair instance Datatype MDProduct where datatypeName _ = "Product" moduleName _ = "Data.Functor.Product" instance Constructor MCPair where conName _ = "Pair" # 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 transformers-compat-0.6.5/tests/0000755000000000000000000000000007346545000015063 5ustar0000000000000000transformers-compat-0.6.5/tests/GenericsSpec.hs0000755000000000000000000000603407346545000017777 0ustar0000000000000000{-# 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 transformers-compat-0.6.5/tests/GenericsTypes.hs0000755000000000000000000001163007346545000020207 0ustar0000000000000000{-# 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__ == 700 || __GLASGOW_HASKELL__ == 804 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__ == 700 -- Workaround for GHC Trac #5041 $(deriveRead ''T#) #elif __GLASGOW_HASKELL__ == 804 -- Workaround for GHC Trac #14918 $(deriveRead ''T#) #else deriving instance Read a => Read (T# a) #endif #if __GLASGOW_HASKELL__ >= 706 deriving instance Generic1 TestParam deriving instance Generic1 T# deriving instance Generic1 Infix deriving instance Generic1 GADT deriving instance Generic1 Record #else $(deriveAll1 ''TestParam) $(deriveAll1 ''T#) $(deriveAll1 ''Infix) $(deriveAll1 ''GADT) $(deriveAll1 ''Record) #endif #if __GLASGOW_HASKELL__ >= 800 deriving instance Generic1 Prim #else $(deriveAll1 ''Prim) #endif #define CLASS1_INSTANCE(class,type,method,impl) \ instance class type where { method = impl }; \ #if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) # define TRANSFORMERS_FOUR 1 #endif #if defined(TRANSFORMERS_FOUR) # define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,eq1,eq1Default) # define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,compare1,compare1Default) # define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,readsPrec1,readsPrec1Default) # define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,showsPrec1,showsPrec1Default) #else # define EQ1_INSTANCE(type) CLASS1_INSTANCE(Eq1,type,liftEq,liftEqDefault) # define ORD1_INSTANCE(type) CLASS1_INSTANCE(Ord1,type,liftCompare,liftCompareDefault) # define READ1_INSTANCE(type) CLASS1_INSTANCE(Read1,type,liftReadsPrec,liftReadsPrecDefault) # define SHOW1_INSTANCE(type) CLASS1_INSTANCE(Show1,type,liftShowsPrec,liftShowsPrecDefault) #endif #define 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) transformers-compat-0.6.5/tests/LICENSE0000755000000000000000000000266007346545000016077 0ustar0000000000000000Copyright 2012-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. transformers-compat-0.6.5/tests/Spec.hs0000755000000000000000000000005407346545000016313 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} transformers-compat-0.6.5/tests/transformers-compat-tests.cabal0000755000000000000000000000343307346545000023223 0ustar0000000000000000name: transformers-compat-tests category: Compatibility version: 0.1 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/transformers-compat/ bug-reports: http://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: transformers-compat tests description: @transformers-copmat@ tests build-type: Simple tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.1 source-repository head type: git location: git://github.com/ekmett/transformers-compat.git flag tests default: True description: Enable the tests. test-suite spec if !flag(tests) buildable: False type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: GenericsSpec GenericsTypes build-depends: base >= 4.3 && < 5 , deriving-compat >= 0.3.4 && < 1 , generic-deriving >= 1.10 && < 2 , hspec >= 2 && < 3 , QuickCheck >= 2 && < 3 , tagged >= 0.7 && < 1 , transformers >= 0.2 && < 0.6 , transformers-compat build-tool-depends: hspec-discover:hspec-discover >= 2 && < 3 hs-source-dirs: . ghc-options: -Wall -threaded -rtsopts transformers-compat-0.6.5/transformers-compat.cabal0000644000000000000000000001256207346545000020721 0ustar0000000000000000name: transformers-compat category: Compatibility version: 0.6.5 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/transformers-compat/ bug-reports: http://github.com/ekmett/transformers-compat/issues copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: A small compatibility shim for the transformers library description: This package includes backported versions of types that were added to transformers in transformers 0.3, 0.4, and 0.5 for users who need strict transformers 0.2 or 0.3 compatibility to run on old versions of the platform, but also need those types. . Those users should be able to just depend on @transformers >= 0.2@ and @transformers-compat >= 0.3@. . Note: missing methods are not supplied, but this at least permits the types to be used. build-type: Simple tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.1 extra-source-files: .travis.yml .ghci .gitignore .vim.custom config tests/*.hs tests/LICENSE tests/transformers-compat-tests.cabal HLint.hs README.markdown CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/transformers-compat.git flag two default: False description: Use transformers 0.2. This will be selected by cabal picking the appropriate version. manual: False flag three default: False manual: False description: Use transformers 0.3. This will be selected by cabal picking the appropriate version. flag four default: False manual: False description: Use transformers 0.4. This will be selected by cabal picking the appropriate version. flag five default: False manual: False description: Use transformers 0.5 up until (but not including) 0.5.3. This will be selected by cabal picking the appropriate version. flag five-three default: False manual: False description: Use transformers 0.5.3. This will be selected by cabal picking the appropriate version. flag mtl default: True manual: True description: -f-mtl Disables support for mtl for transformers 0.2 and 0.3. That is an unsupported configuration, and results in missing instances for `ExceptT`. 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, -- These are all transformers versions we support. -- each flag below splits this interval into two parts. -- flag-true parts are mutually exclusive, so at least one have to be on. transformers >= 0.2 && <0.6 if !impl(ghc >= 8.0) build-depends: fail == 4.9.* hs-source-dirs: src exposed-modules: Control.Monad.Trans.Instances other-modules: Paths_transformers_compat -- automatic flags if flag(five-three) build-depends: transformers >= 0.5.3 else build-depends: transformers < 0.5.3 if flag(five) hs-source-dirs: 0.5 build-depends: transformers >= 0.5 && < 0.5.3 else build-depends: transformers < 0.5 || >= 0.5.3 if flag(four) cpp-options: -DTRANSFORMERS_FOUR hs-source-dirs: 0.5 -- Don't allow transformers-0.4.0.0 -- See https://github.com/ekmett/transformers-compat/issues/35 build-depends: transformers >= 0.4.1 && < 0.5 else build-depends: transformers < 0.4 || >= 0.5 if flag(three) hs-source-dirs: 0.3 0.5 build-depends: transformers >= 0.3 && < 0.4 if flag(mtl) build-depends: mtl >= 2.1 && < 2.2 else build-depends: transformers < 0.3 || >= 0.4 if flag(two) hs-source-dirs: 0.2 0.3 0.5 build-depends: transformers >= 0.2 && < 0.3 if flag(mtl) build-depends: mtl >= 2.0 && < 2.1 else build-depends: transformers >= 0.3 -- other flags 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 Control.Applicative.Lift Data.Functor.Reverse if flag(two) || flag(three) exposed-modules: Control.Monad.Trans.Except Control.Monad.Signatures Data.Functor.Classes Data.Functor.Sum if flag(two) || flag(three) || flag(four) || flag(five) 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