transformers-compat-0.5.1.4/0000755000000000000000000000000012646607327014070 5ustar0000000000000000transformers-compat-0.5.1.4/.ghci0000644000000000000000000000012512646607327015001 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h transformers-compat-0.5.1.4/.gitignore0000644000000000000000000000006512646607327016061 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo transformers-compat-0.5.1.4/.travis.yml0000644000000000000000000000136012646607327016201 0ustar0000000000000000language: haskell before_install: # Uncomment whenever hackage is down. # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update # Try installing some of the build-deps with apt-get for speed. - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode - sudo apt-get -q -y install hlint || cabal install hlint install: - cabal configure $mode - cabal build script: - $script - hlint 0.2 --cpp-define HLINT - hlint 0.3 --cpp-define HLINT notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313transformers-compat\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" env: - mode="--enable-tests" script="cabal test" transformers-compat-0.5.1.4/.vim.custom0000644000000000000000000000137712646607327016205 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.5.1.4/CHANGELOG.markdown0000644000000000000000000000334212646607327017125 0ustar00000000000000000.4.0.4 ------- 0.4.0.3 ------- 0.4.0.2 ------- * Each of these is a build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker. 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 ------- 0.3.3.3 ------- 0.3.3.2 ------- * These releases 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. 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.5.1.4/config0000644000000000000000000000120612646607327015257 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.5.1.4/HLint.hs0000644000000000000000000000003712646607327015442 0ustar0000000000000000ignore "Warning: Avoid lambda" transformers-compat-0.5.1.4/LICENSE0000644000000000000000000000266012646607327015101 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.5.1.4/README.markdown0000644000000000000000000000135512646607327016575 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. 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.5.1.4/Setup.lhs0000644000000000000000000000016512646607327015702 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain transformers-compat-0.5.1.4/transformers-compat.cabal0000644000000000000000000000536512646607327021073 0ustar0000000000000000name: transformers-compat category: Compatibility version: 0.5.1.4 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 exposing the new types from transformers 0.3 and 0.4 to older Haskell platforms. 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.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.8.2, GHC == 7.10.3, GHC == 8.0.1 extra-source-files: .travis.yml .ghci .gitignore .vim.custom config 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: True flag three default: False manual: True description: Use transformers 0.3. This will be selected by cabal picking the appropriate version. flag mtl default: True manual: True description: -f-mtl Disables support for mtl for transformers 0.2 and 0.3. That is an unsupported configuration, and results in missing instances for `ExceptT`, but keeps the package Haskell 98. library build-depends: base >= 4.3 && < 5 hs-source-dirs: src exposed-modules: Control.Monad.Trans.Instances other-modules: Paths_transformers_compat if flag(three) hs-source-dirs: 0.3 build-depends: transformers >= 0.3 && < 0.4, mtl >= 2.1 && < 2.2 else if flag(two) hs-source-dirs: 0.2 0.3 build-depends: transformers >= 0.2 && < 0.3, mtl >= 2.0 && < 2.1 else build-depends: transformers >= 0.4.1 && < 0.6 if !flag(mtl) cpp-options: -DHASKELL98 else build-depends: ghc-prim 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 transformers-compat-0.5.1.4/0.2/0000755000000000000000000000000012646607327014367 5ustar0000000000000000transformers-compat-0.5.1.4/0.2/Control/0000755000000000000000000000000012646607327016007 5ustar0000000000000000transformers-compat-0.5.1.4/0.2/Control/Applicative/0000755000000000000000000000000012646607327020250 5ustar0000000000000000transformers-compat-0.5.1.4/0.2/Control/Applicative/Backwards.hs0000644000000000000000000000541012646607327022505 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif #endif -- | -- Module : Control.Applicative.Backwards -- Copyright : (c) Russell O'Connor 2009 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- Making functors with an 'Applicative' instance that performs actions -- in the reverse order. -- -- NB: This module is only included in @lens@ for backwards compatibility with -- @transformers@ versions before 3.0. module Control.Applicative.Backwards where import Data.Functor.Classes import Prelude hiding (foldr, foldr1, foldl, foldl1) import Control.Applicative import Data.Foldable import Data.Traversable -- | The same functor, but with an 'Applicative' instance that performs -- actions in the reverse order. newtype Backwards f a = Backwards { forwards :: f a } instance (Eq1 f) => Eq1 (Backwards f) where liftEq eq (Backwards x) (Backwards y) = liftEq eq x y instance (Ord1 f) => Ord1 (Backwards f) where liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y instance (Read1 f) => Read1 (Backwards f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards instance (Show1 f) => Show1 (Backwards f) where liftShowsPrec sp sl d (Backwards x) = showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 -- | Derived instance. instance (Functor f) => Functor (Backwards f) where fmap f (Backwards a) = Backwards (fmap f a) -- | Apply @f@-actions in the reverse order. instance (Applicative f) => Applicative (Backwards f) where pure a = Backwards (pure a) Backwards f <*> Backwards a = Backwards (a <**> f) -- | Try alternatives in the same order as @f@. instance (Alternative f) => Alternative (Backwards f) where empty = Backwards empty Backwards x <|> Backwards y = Backwards (x <|> y) -- | Derived instance. instance (Foldable f) => Foldable (Backwards f) where foldMap f (Backwards t) = foldMap f t foldr f z (Backwards t) = foldr f z t foldl f z (Backwards t) = foldl f z t foldr1 f (Backwards t) = foldr1 f t foldl1 f (Backwards t) = foldl1 f t -- | Derived instance. instance (Traversable f) => Traversable (Backwards f) where traverse f (Backwards t) = fmap Backwards (traverse f t) sequenceA (Backwards t) = fmap Backwards (sequenceA t) transformers-compat-0.5.1.4/0.2/Control/Applicative/Lift.hs0000644000000000000000000001037112646607327021504 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, -- * Collecting errors Errors, runErrors, failure ) where import Data.Functor.Classes import Control.Applicative import Data.Foldable (Foldable(foldMap)) import Data.Functor.Constant import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) -- | Applicative functor formed by adding pure computations to a given -- applicative functor. data Lift f a = Pure a | Other (f a) instance (Eq1 f) => Eq1 (Lift f) where liftEq eq (Pure x1) (Pure x2) = eq x1 x2 liftEq _ (Pure _) (Other _) = False liftEq _ (Other _) (Pure _) = False liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 instance (Ord1 f) => Ord1 (Lift f) where liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 liftCompare _ (Pure _) (Other _) = LT liftCompare _ (Other _) (Pure _) = GT liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 instance (Read1 f) => Read1 (Lift f) where liftReadsPrec rp rl = readsData $ readsUnaryWith rp "Pure" Pure `mappend` readsUnaryWith (liftReadsPrec rp rl) "Other" Other instance (Show1 f) => Show1 (Lift f) where liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x liftShowsPrec sp sl d (Other y) = showsUnaryWith (liftShowsPrec sp sl) "Other" d y instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 instance (Functor f) => Functor (Lift f) where fmap f (Pure x) = Pure (f x) fmap f (Other y) = Other (fmap f y) instance (Foldable f) => Foldable (Lift f) where foldMap f (Pure x) = f x foldMap f (Other y) = foldMap f y instance (Traversable f) => Traversable (Lift f) where traverse f (Pure x) = Pure <$> f x traverse f (Other y) = Other <$> traverse f y -- | A combination is 'Pure' only if both parts are. instance (Applicative f) => Applicative (Lift f) where pure = Pure Pure f <*> Pure x = Pure (f x) Pure f <*> Other y = Other (f <$> y) Other f <*> Pure x = Other (($ x) <$> f) Other f <*> Other y = Other (f <*> y) -- | A combination is 'Pure' only either part is. instance (Alternative f) => Alternative (Lift f) where empty = Other empty Pure x <|> _ = Pure x Other _ <|> Pure y = Pure y Other x <|> Other y = Other (x <|> y) -- | Projection to the other functor. unLift :: (Applicative f) => Lift f a -> f a unLift (Pure x) = pure x unLift (Other e) = e -- | Apply a transformation to the other computation. mapLift :: (f a -> g a) -> Lift f a -> Lift g a mapLift _ (Pure x) = Pure x mapLift f (Other e) = Other (f e) -- | An applicative functor that collects a monoid (e.g. lists) of errors. -- A sequence of computations fails if any of its components do, but -- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except", -- these computations continue after an error, collecting all the errors. -- -- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@ -- -- * @'pure' f '<*>' 'failure' e = 'failure' e@ -- -- * @'failure' e '<*>' 'pure' x = 'failure' e@ -- -- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@ -- type Errors e = Lift (Constant e) -- | Extractor for computations with accumulating errors. -- -- * @'runErrors' ('pure' x) = 'Right' x@ -- -- * @'runErrors' ('failure' e) = 'Left' e@ -- runErrors :: Errors e a -> Either e a runErrors (Other (Constant e)) = Left e runErrors (Pure x) = Right x -- | Report an error. failure :: e -> Errors e a failure e = Other (Constant e) transformers-compat-0.5.1.4/0.2/Data/0000755000000000000000000000000012646607327015240 5ustar0000000000000000transformers-compat-0.5.1.4/0.2/Data/Functor/0000755000000000000000000000000012646607327016660 5ustar0000000000000000transformers-compat-0.5.1.4/0.2/Data/Functor/Reverse.hs0000644000000000000000000000550712646607327020636 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif #endif -- | -- Module : Data.Functor.Reverse -- Copyright : (c) Russell O'Connor 2009 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- Making functors whose elements are notionally in the reverse order -- from the original functor. -- -- /NB:/ Note this module is only included in @lens@ for backwards -- compatibility with older @containers@ versions. module Data.Functor.Reverse where import Control.Applicative.Backwards import Data.Functor.Classes import Prelude hiding (foldr, foldr1, foldl, foldl1) import Control.Applicative import Data.Foldable import Data.Traversable import Data.Monoid -- | The same functor, but with 'Foldable' and 'Traversable' instances -- that process the elements in the reverse order. newtype Reverse f a = Reverse { getReverse :: f a } instance (Eq1 f) => Eq1 (Reverse f) where liftEq eq (Reverse x) (Reverse y) = liftEq eq x y instance (Ord1 f) => Ord1 (Reverse f) where liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y instance (Read1 f) => Read1 (Reverse f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse instance (Show1 f) => Show1 (Reverse f) where liftShowsPrec sp sl d (Reverse x) = showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 -- | Derived instance. instance (Functor f) => Functor (Reverse f) where fmap f (Reverse a) = Reverse (fmap f a) -- | Derived instance. instance (Applicative f) => Applicative (Reverse f) where pure a = Reverse (pure a) Reverse f <*> Reverse a = Reverse (f <*> a) -- | Derived instance. instance (Alternative f) => Alternative (Reverse f) where empty = Reverse empty Reverse x <|> Reverse y = Reverse (x <|> y) -- | Fold from right to left. instance (Foldable f) => Foldable (Reverse f) where foldMap f (Reverse t) = getDual (foldMap (Dual . f) t) foldr f z (Reverse t) = foldl (flip f) z t foldl f z (Reverse t) = foldr (flip f) z t foldr1 f (Reverse t) = foldl1 (flip f) t foldl1 f (Reverse t) = foldr1 (flip f) t -- | Traverse from right to left. instance (Traversable f) => Traversable (Reverse f) where traverse f (Reverse t) = fmap Reverse . forwards $ traverse (Backwards . f) t sequenceA (Reverse t) = fmap Reverse . forwards $ sequenceA (fmap Backwards t) transformers-compat-0.5.1.4/0.3/0000755000000000000000000000000012646607327014370 5ustar0000000000000000transformers-compat-0.5.1.4/0.3/Control/0000755000000000000000000000000012646607327016010 5ustar0000000000000000transformers-compat-0.5.1.4/0.3/Control/Monad/0000755000000000000000000000000012646607327017046 5ustar0000000000000000transformers-compat-0.5.1.4/0.3/Control/Monad/Signatures.hs0000644000000000000000000000336112646607327021531 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Signatures -- Copyright : (c) Ross Paterson 2012 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- Signatures for monad operations that require specialized lifting. -- Each signature has a uniformity property that the lifting should satisfy. ----------------------------------------------------------------------------- module Control.Monad.Signatures ( CallCC, Catch, Listen, Pass ) where -- | Signature of the @callCC@ operation, -- introduced in "Control.Monad.Trans.Cont". -- Any lifting function @liftCallCC@ should satisfy -- -- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@ -- type CallCC m a b = ((a -> m b) -> m a) -> m a -- | Signature of the @catchE@ operation, -- introduced in "Control.Monad.Trans.Except". -- Any lifting function @liftCatch@ should satisfy -- -- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@ -- type Catch e m a = m a -> (e -> m a) -> m a -- | Signature of the @listen@ operation, -- introduced in "Control.Monad.Trans.Writer". -- Any lifting function @liftListen@ should satisfy -- -- * @'lift' . liftListen = liftListen . 'lift'@ -- type Listen w m a = m a -> m (a, w) -- | Signature of the @pass@ operation, -- introduced in "Control.Monad.Trans.Writer". -- Any lifting function @liftPass@ should satisfy -- -- * @'lift' . liftPass = liftPass . 'lift'@ -- type Pass w m a = m (a, w -> w) -> m a transformers-compat-0.5.1.4/0.3/Control/Monad/Trans/0000755000000000000000000000000012646607327020135 5ustar0000000000000000transformers-compat-0.5.1.4/0.3/Control/Monad/Trans/Except.hs0000644000000000000000000002307212646607327021725 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 #ifndef HASKELL98 {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} # endif #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Except -- Copyright : (C) 2013 Ross Paterson -- (C) 2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- This monad transformer extends a monad with the ability throw exceptions. -- -- A sequence of actions terminates normally, producing a value, -- only if none of the actions in the sequence throws an exception. -- If one throws an exception, the rest of the sequence is skipped and -- the composite action exits with that exception. -- -- If the value of the exception is not required, the variant in -- "Control.Monad.Trans.Maybe" may be used instead. ----------------------------------------------------------------------------- module Control.Monad.Trans.Except ( -- * The Except monad Except, except, runExcept, mapExcept, withExcept, -- * The ExceptT monad transformer ExceptT(..), mapExceptT, withExceptT, -- * Exception operations throwE, catchE, -- * Lifting other operations liftCallCC, liftListen, liftPass, ) where import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Signatures import Control.Monad.Trans.Class #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip (MonadZip(mzipWith)) #endif #ifndef HASKELL98 import Control.Monad.Writer.Class import Control.Monad.State.Class import Control.Monad.Reader.Class import Control.Monad.Cont.Class import Control.Monad.Error.Class import Control.Monad.RWS.Class #endif import Data.Foldable (Foldable(foldMap)) import Data.Functor.Classes import Data.Functor.Identity import Data.Monoid import Data.Traversable (Traversable(traverse)) -- | The parameterizable exception monad. -- -- Computations are either exceptions or normal values. -- -- The 'return' function returns a normal value, while @>>=@ exits -- on the first exception. type Except e = ExceptT e Identity -- | Constructor for computations in the exception monad. -- (The inverse of 'runExcept'). except :: Either e a -> Except e a except m = ExceptT (Identity m) -- | Extractor for computations in the exception monad. -- (The inverse of 'except'). runExcept :: Except e a -> Either e a runExcept (ExceptT m) = runIdentity m -- | Map the unwrapped computation using the given function. -- -- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@ mapExcept :: (Either e a -> Either e' b) -> Except e a -> Except e' b mapExcept f = mapExceptT (Identity . f . runIdentity) -- | Transform any exceptions thrown by the computation using the given -- function (a specialization of 'withExceptT'). withExcept :: (e -> e') -> Except e a -> Except e' a withExcept = withExceptT -- | A monad transformer that adds exceptions to other monads. -- -- @ExceptT@ constructs a monad parameterized over two things: -- -- * e - The exception type. -- -- * m - The inner monad. -- -- The 'return' function yields a computation that produces the given -- value, while @>>=@ sequences two subcomputations, exiting on the -- first exception. newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where liftCompare comp (ExceptT x) (ExceptT y) = liftCompare (liftCompare comp) x y instance (Read e, Read1 m) => Read1 (ExceptT e m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show e, Show1 m) => Show1 (ExceptT e m) where liftShowsPrec sp sl d (ExceptT m) = showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1 instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1 instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where readsPrec = readsPrec1 instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where showsPrec = showsPrec1 -- | Map the unwrapped computation using the given function. -- -- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b mapExceptT f m = ExceptT $ f (runExceptT m) -- | Transform any exceptions thrown by the computation using the -- given function. withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a withExceptT f = mapExceptT $ fmap $ either (Left . f) Right instance (Functor m) => Functor (ExceptT e m) where fmap f = ExceptT . fmap (fmap f) . runExceptT instance (Foldable f) => Foldable (ExceptT e f) where foldMap f (ExceptT a) = foldMap (either (const mempty) f) a instance (Traversable f) => Traversable (ExceptT e f) where traverse f (ExceptT a) = ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a instance (Functor m, Monad m) => Applicative (ExceptT e m) where pure a = ExceptT $ return (Right a) ExceptT f <*> ExceptT v = ExceptT $ do mf <- f case mf of Left e -> return (Left e) Right k -> do mv <- v case mv of Left e -> return (Left e) Right x -> return (Right (k x)) instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where empty = ExceptT $ return (Left mempty) ExceptT mx <|> ExceptT my = ExceptT $ do ex <- mx case ex of Left e -> liftM (either (Left . mappend e) Right) my Right x -> return (Right x) instance (Monad m) => Monad (ExceptT e m) where return a = ExceptT $ return (Right a) m >>= k = ExceptT $ do a <- runExceptT m case a of Left e -> return (Left e) Right x -> runExceptT (k x) fail = ExceptT . fail instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where mzero = ExceptT $ return (Left mempty) ExceptT m `mplus` ExceptT n = ExceptT $ do a <- m case a of Left e -> liftM (either (Left . mappend e) Right) n Right x -> return (Right x) instance (MonadFix m) => MonadFix (ExceptT e m) where mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id)) where bomb = error "mfix (ExceptT): inner computation returned Left value" instance MonadTrans (ExceptT e) where lift = ExceptT . liftM Right instance (MonadIO m) => MonadIO (ExceptT e m) where liftIO = lift . liftIO #if MIN_VERSION_base(4,4,0) instance (MonadZip m) => MonadZip (ExceptT e m) where mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b #endif -- | Signal an exception value @e@. -- -- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@ -- -- * @'throwE' e >>= m = 'throwE' e@ throwE :: (Monad m) => e -> ExceptT e m a throwE = ExceptT . return . Left -- | Handle an exception. -- -- * @'catchE' h ('lift' m) = 'lift' m@ -- -- * @'catchE' h ('throwE' e) = h e@ catchE :: (Monad m) => ExceptT e m a -- ^ the inner computation -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner -- computation -> ExceptT e' m a m `catchE` h = ExceptT $ do a <- runExceptT m case a of Left l -> runExceptT (h l) Right r -> return (Right r) -- | Lift a @callCC@ operation to the new monad. liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b liftCallCC callCC f = ExceptT $ callCC $ \ c -> runExceptT (f (\ a -> ExceptT $ c (Right a))) -- | Lift a @listen@ operation to the new monad. liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a liftListen listen = mapExceptT $ \ m -> do (a, w) <- listen m return $! fmap (\ r -> (r, w)) a -- | Lift a @pass@ operation to the new monad. liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a liftPass pass = mapExceptT $ \ m -> pass $ do a <- m return $! case a of Left l -> (Left l, id) Right (r, f) -> (Right r, f) -- incurring the mtl dependency for these avoids packages that need them introducing orphans. #ifndef HASKELL98 instance Monad m => MonadError e (ExceptT e m) where throwError = throwE catchError = catchE instance MonadWriter w m => MonadWriter w (ExceptT e m) where tell = lift . tell listen = liftListen listen pass = liftPass pass #if MIN_VERSION_mtl(2,1,0) writer = lift . writer #endif instance MonadState s m => MonadState s (ExceptT e m) where get = lift get put = lift . put #if MIN_VERSION_mtl(2,1,0) state = lift . state #endif instance MonadReader r m => MonadReader r (ExceptT e m) where ask = lift ask local = mapExceptT . local #if MIN_VERSION_mtl(2,1,0) reader = lift . reader #endif instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m) instance MonadCont m => MonadCont (ExceptT e m) where callCC = liftCallCC callCC #endif transformers-compat-0.5.1.4/0.3/Data/0000755000000000000000000000000012646607327015241 5ustar0000000000000000transformers-compat-0.5.1.4/0.3/Data/Functor/0000755000000000000000000000000012646607327016661 5ustar0000000000000000transformers-compat-0.5.1.4/0.3/Data/Functor/Classes.hs0000644000000000000000000007730212646607327020623 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) import Text.Show (showListWith) import Control.Monad.Trans.Error import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Product #if MIN_VERSION_transformers(0,3,0) import Control.Applicative.Lift import Control.Applicative.Backwards import Data.Functor.Reverse #endif #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 708 import Data.Typeable # endif #endif -- | Lifting of the 'Eq' class to unary type constructors. class Eq1 f where -- | Lift an equality test through the type constructor. -- -- The function will usually be applied to an equality function, -- but the more general type ensures that the implementation uses -- it to compare elements of the first container with elements of -- the second. liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool -- | Lift the standard @('==')@ function through the type constructor. eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool eq1 = liftEq (==) -- | Lifting of the 'Ord' class to unary type constructors. class (Eq1 f) => Ord1 f where -- | Lift a 'compare' function through the type constructor. -- -- The function will usually be applied to a comparison function, -- but the more general type ensures that the implementation uses -- it to compare elements of the first container with elements of -- the second. liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering -- | Lift the standard 'compare' function through the type constructor. compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering compare1 = liftCompare compare -- | Lifting of the 'Read' class to unary type constructors. class Read1 f where -- | 'readsPrec' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument type. liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) -- | 'readList' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument type. -- The default implementation using standard list syntax is correct -- for most types. liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) -- | Read a list (using square brackets and commas), given a function -- for reading elements. readListWith :: ReadS a -> ReadS [a] readListWith rp = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) where readl s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] readl' s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] -- | Lift the standard 'readsPrec' and 'readList' functions through the -- type constructor. readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) readsPrec1 = liftReadsPrec readsPrec readList -- | Lifting of the 'Show' class to unary type constructors. class Show1 f where -- | 'showsPrec' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument type. liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS -- | 'showList' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument type. -- The default implementation using standard list syntax is correct -- for most types. liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) -- | Lift the standard 'showsPrec' and 'showList' functions through the -- type constructor. showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS showsPrec1 = liftShowsPrec showsPrec showList -- | Lifting of the 'Eq' class to binary type constructors. class Eq2 f where -- | Lift equality tests through the type constructor. -- -- The function will usually be applied to equality functions, -- but the more general type ensures that the implementation uses -- them to compare elements of the first container with elements of -- the second. liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool -- | Lift the standard @('==')@ function through the type constructor. eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool eq2 = liftEq2 (==) (==) -- | Lifting of the 'Ord' class to binary type constructors. class (Eq2 f) => Ord2 f where -- | Lift 'compare' functions through the type constructor. -- -- The function will usually be applied to comparison functions, -- but the more general type ensures that the implementation uses -- them to compare elements of the first container with elements of -- the second. liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> f a c -> f b d -> Ordering -- | Lift the standard 'compare' function through the type constructor. compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering compare2 = liftCompare2 compare compare -- | Lifting of the 'Read' class to binary type constructors. class Read2 f where -- | 'readsPrec' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument types. liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) -- | 'readList' function for an application of the type constructor -- based on 'readsPrec' and 'readList' functions for the argument types. -- The default implementation using standard list syntax is correct -- for most types. liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] liftReadList2 rp1 rl1 rp2 rl2 = readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) -- | Lift the standard 'readsPrec' function through the type constructor. readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList -- | Lifting of the 'Show' class to binary type constructors. class Show2 f where -- | 'showsPrec' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument types. liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS -- | 'showList' function for an application of the type constructor -- based on 'showsPrec' and 'showList' functions for the argument types. -- The default implementation using standard list syntax is correct -- for most types. liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS liftShowList2 sp1 sl1 sp2 sl2 = showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) -- | Lift the standard 'showsPrec' function through the type constructor. showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList -- Instances for Prelude type constructors instance Eq1 Maybe where liftEq _ Nothing Nothing = True liftEq _ Nothing (Just _) = False liftEq _ (Just _) Nothing = False liftEq eq (Just x) (Just y) = eq x y instance Ord1 Maybe where liftCompare _ Nothing Nothing = EQ liftCompare _ Nothing (Just _) = LT liftCompare _ (Just _) Nothing = GT liftCompare comp (Just x) (Just y) = comp x y instance Read1 Maybe where liftReadsPrec rp _ d = readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) `mappend` readsData (readsUnaryWith rp "Just" Just) d instance Show1 Maybe where liftShowsPrec _ _ _ Nothing = showString "Nothing" liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x instance Eq1 [] where liftEq _ [] [] = True liftEq _ [] (_:_) = False liftEq _ (_:_) [] = False liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys instance Ord1 [] where liftCompare _ [] [] = EQ liftCompare _ [] (_:_) = LT liftCompare _ (_:_) [] = GT liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys instance Read1 [] where liftReadsPrec _ rl _ = rl instance Show1 [] where liftShowsPrec _ sl _ = sl instance Eq2 (,) where liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 instance Ord2 (,) where liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = comp1 x1 x2 `mappend` comp2 y1 y2 instance Read2 (,) where liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> [((x,y), w) | ("(",s) <- lex r, (x,t) <- rp1 0 s, (",",u) <- lex t, (y,v) <- rp2 0 u, (")",w) <- lex v] instance Show2 (,) where liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' instance (Eq a) => Eq1 ((,) a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 ((,) a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 ((,) a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 ((,) a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Eq2 Either where liftEq2 e1 _ (Left x) (Left y) = e1 x y liftEq2 _ _ (Left _) (Right _) = False liftEq2 _ _ (Right _) (Left _) = False liftEq2 _ e2 (Right x) (Right y) = e2 x y instance Ord2 Either where liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y liftCompare2 _ _ (Left _) (Right _) = LT liftCompare2 _ _ (Right _) (Left _) = GT liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y instance Read2 Either where liftReadsPrec2 rp1 _ rp2 _ = readsData $ readsUnaryWith rp1 "Left" Left `mappend` readsUnaryWith rp2 "Right" Right instance Show2 Either where liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x instance (Eq a) => Eq1 (Either a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 (Either a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 (Either a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 (Either a) where liftShowsPrec = liftShowsPrec2 showsPrec showList -- Instances for other functors defined in the base package instance Eq1 Identity where liftEq eq (Identity x) (Identity y) = eq x y instance Ord1 Identity where liftCompare comp (Identity x) (Identity y) = comp x y instance Read1 Identity where liftReadsPrec rp _ = readsData $ readsUnaryWith rp "Identity" Identity instance Show1 Identity where liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x instance Eq2 Const where liftEq2 eq _ (Const x) (Const y) = eq x y instance Ord2 Const where liftCompare2 comp _ (Const x) (Const y) = comp x y instance Read2 Const where liftReadsPrec2 rp _ _ _ = readsData $ readsUnaryWith rp "Const" Const instance Show2 Const where liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x instance (Eq a) => Eq1 (Const a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 (Const a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 (Const a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 (Const a) where liftShowsPrec = liftShowsPrec2 showsPrec showList -- Building blocks -- | @'readsData' p d@ is a parser for datatypes where each alternative -- begins with a data constructor. It parses the constructor and -- passes it to @p@. Parsers for various constructors can be constructed -- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with -- @mappend@ from the @Monoid@ class. readsData :: (String -> ReadS a) -> Int -> ReadS a readsData reader d = readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] -- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor -- and then parses its argument using @rp@. readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t readsUnaryWith rp name cons kw s = [(cons x,t) | kw == name, (x,t) <- rp 11 s] -- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary -- data constructor and then parses its arguments using @rp1@ and @rp2@ -- respectively. readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> String -> (a -> b -> t) -> String -> ReadS t readsBinaryWith rp1 rp2 name cons kw s = [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] -- | @'showsUnaryWith' sp n d x@ produces the string representation of a -- unary data constructor with name @n@ and argument @x@, in precedence -- context @d@. showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS showsUnaryWith sp name d x = showParen (d > 10) $ showString name . showChar ' ' . sp 11 x -- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string -- representation of a binary data constructor with name @n@ and arguments -- @x@ and @y@, in precedence context @d@. showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y -- Obsolete building blocks -- | @'readsUnary' n c n'@ matches the name of a unary data constructor -- and then parses its argument using 'readsPrec'. {-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t readsUnary name cons kw s = [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] -- | @'readsUnary1' n c n'@ matches the name of a unary data constructor -- and then parses its argument using 'readsPrec1'. {-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t readsUnary1 name cons kw s = [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] -- | @'readsBinary1' n c n'@ matches the name of a binary data constructor -- and then parses its arguments using 'readsPrec1'. {-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} readsBinary1 :: (Read1 f, Read1 g, Read a) => String -> (f a -> g a -> t) -> String -> ReadS t readsBinary1 name cons kw s = [(cons x y,u) | kw == name, (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] -- | @'showsUnary' n d x@ produces the string representation of a unary data -- constructor with name @n@ and argument @x@, in precedence context @d@. {-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} showsUnary :: (Show a) => String -> Int -> a -> ShowS showsUnary name d x = showParen (d > 10) $ showString name . showChar ' ' . showsPrec 11 x -- | @'showsUnary1' n d x@ produces the string representation of a unary data -- constructor with name @n@ and argument @x@, in precedence context @d@. {-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS showsUnary1 name d x = showParen (d > 10) $ showString name . showChar ' ' . showsPrec1 11 x -- | @'showsBinary1' n d x y@ produces the string representation of a binary -- data constructor with name @n@ and arguments @x@ and @y@, in precedence -- context @d@. {-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} showsBinary1 :: (Show1 f, Show1 g, Show a) => String -> Int -> f a -> g a -> ShowS showsBinary1 name d x y = showParen (d > 10) $ showString name . showChar ' ' . showsPrec1 11 x . showChar ' ' . showsPrec1 11 y instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y instance (Read e, Read1 m) => Read1 (ErrorT e m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show e, Show1 m) => Show1 (ErrorT e m) where liftShowsPrec sp sl d (ErrorT m) = showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1 instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1 instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where readsPrec = readsPrec1 instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where showsPrec = showsPrec1 instance (Eq1 f) => Eq1 (IdentityT f) where liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y instance (Ord1 f) => Ord1 (IdentityT f) where liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y instance (Read1 f) => Read1 (IdentityT f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT instance (Show1 f) => Show1 (IdentityT f) where liftShowsPrec sp sl d (IdentityT m) = showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1 instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1 instance (Eq1 m) => Eq1 (ListT m) where liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y instance (Ord1 m) => Ord1 (ListT m) where liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y instance (Read1 m) => Read1 (ListT m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show1 m) => Show1 (ListT m) where liftShowsPrec sp sl d (ListT m) = showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1 instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1 instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1 instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 instance (Eq1 m) => Eq1 (MaybeT m) where liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y instance (Ord1 m) => Ord1 (MaybeT m) where liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y instance (Read1 m) => Read1 (MaybeT m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show1 m) => Show1 (MaybeT m) where liftShowsPrec sp sl d (MaybeT m) = showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1 instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1 instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1 instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) = liftCompare (liftCompare2 comp compare) m1 m2 instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT where rp' = liftReadsPrec2 rp rl readsPrec readList rl' = liftReadList2 rp rl readsPrec readList instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where liftShowsPrec sp sl d (Lazy.WriterT m) = showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m where sp' = liftShowsPrec2 sp sl showsPrec showList sl' = liftShowList2 sp sl showsPrec showList instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where (==) = eq1 instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where compare = compare1 instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where readsPrec = readsPrec1 instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where showsPrec = showsPrec1 instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) = liftCompare (liftCompare2 comp compare) m1 m2 instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT where rp' = liftReadsPrec2 rp rl readsPrec readList rl' = liftReadList2 rp rl readsPrec readList instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where liftShowsPrec sp sl d (Strict.WriterT m) = showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m where sp' = liftShowsPrec2 sp sl showsPrec showList sl' = liftShowList2 sp sl showsPrec showList instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where (==) = eq1 instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where compare = compare1 instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where readsPrec = readsPrec1 instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where showsPrec = showsPrec1 instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where liftCompare comp (Compose x) (Compose y) = liftCompare (liftCompare comp) x y instance (Read1 f, Read1 g) => Read1 (Compose f g) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl instance (Show1 f, Show1 g) => Show1 (Compose f g) where liftShowsPrec sp sl d (Compose x) = showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where (==) = eq1 instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where compare = compare1 instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where readsPrec = readsPrec1 instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where showsPrec = showsPrec1 instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where liftCompare comp (Pair x1 y1) (Pair x2 y2) = liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 instance (Read1 f, Read1 g) => Read1 (Product f g) where liftReadsPrec rp rl = readsData $ readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair instance (Show1 f, Show1 g) => Show1 (Product f g) where liftShowsPrec sp sl d (Pair x y) = showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) where (==) = eq1 instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where compare = compare1 instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where readsPrec = readsPrec1 instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where showsPrec = showsPrec1 instance Eq2 Constant where liftEq2 eq _ (Constant x) (Constant y) = eq x y instance Ord2 Constant where liftCompare2 comp _ (Constant x) (Constant y) = comp x y instance Read2 Constant where liftReadsPrec2 rp _ _ _ = readsData $ readsUnaryWith rp "Constant" Constant instance Show2 Constant where liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x instance (Eq a) => Eq1 (Constant a) where liftEq = liftEq2 (==) instance (Ord a) => Ord1 (Constant a) where liftCompare = liftCompare2 compare instance (Read a) => Read1 (Constant a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Show a) => Show1 (Constant a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Eq a => Eq (Constant a b) where Constant a == Constant b = a == b instance Ord a => Ord (Constant a b) where compare (Constant a) (Constant b) = compare a b instance (Read a) => Read (Constant a b) where readsPrec = readsData $ readsUnaryWith readsPrec "Constant" Constant instance (Show a) => Show (Constant a b) where showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x instance Show a => Show (Identity a) where showsPrec d (Identity a) = showParen (d > 10) $ showString "Identity " . showsPrec 11 a instance Read a => Read (Identity a) where readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s]) instance Eq a => Eq (Identity a) where Identity a == Identity b = a == b instance Ord a => Ord (Identity a) where compare (Identity a) (Identity b) = compare a b #if MIN_VERSION_transformers(0,3,0) instance (Eq1 f) => Eq1 (Lift f) where liftEq eq (Pure x1) (Pure x2) = eq x1 x2 liftEq _ (Pure _) (Other _) = False liftEq _ (Other _) (Pure _) = False liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 instance (Ord1 f) => Ord1 (Lift f) where liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 liftCompare _ (Pure _) (Other _) = LT liftCompare _ (Other _) (Pure _) = GT liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 instance (Read1 f) => Read1 (Lift f) where liftReadsPrec rp rl = readsData $ readsUnaryWith rp "Pure" Pure `mappend` readsUnaryWith (liftReadsPrec rp rl) "Other" Other instance (Show1 f) => Show1 (Lift f) where liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x liftShowsPrec sp sl d (Other y) = showsUnaryWith (liftShowsPrec sp sl) "Other" d y instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 instance (Eq1 f) => Eq1 (Backwards f) where liftEq eq (Backwards x) (Backwards y) = liftEq eq x y instance (Ord1 f) => Ord1 (Backwards f) where liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y instance (Read1 f) => Read1 (Backwards f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards instance (Show1 f) => Show1 (Backwards f) where liftShowsPrec sp sl d (Backwards x) = showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 instance (Eq1 f) => Eq1 (Reverse f) where liftEq eq (Reverse x) (Reverse y) = liftEq eq x y instance (Ord1 f) => Ord1 (Reverse f) where liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y instance (Read1 f) => Read1 (Reverse f) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse instance (Show1 f) => Show1 (Reverse f) where liftShowsPrec sp sl d (Reverse x) = showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 #endif #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable Eq1 deriving instance Typeable Eq2 deriving instance Typeable Ord1 deriving instance Typeable Ord2 deriving instance Typeable Read1 deriving instance Typeable Read2 deriving instance Typeable Show1 deriving instance Typeable Show2 # endif #endif {- $example These functions can be used to assemble 'Read' and 'Show' instances for new algebraic types. For example, given the definition > data T f a = Zero a | One (f a) | Two a (f a) a standard 'Read1' instance may be defined as > instance (Read1 f) => Read1 (T f) where > liftReadsPrec rp rl = readsData $ > readsUnaryWith rp "Zero" Zero `mappend` > readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` > readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two and the corresponding 'Show1' instance as > instance (Show1 f) => Show1 (T f) where > liftShowsPrec sp _ d (Zero x) = > showsUnaryWith sp "Zero" d x > liftShowsPrec sp sl d (One x) = > showsUnaryWith (liftShowsPrec sp sl) "One" d x > liftShowsPrec sp sl d (Two x y) = > showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y -} transformers-compat-0.5.1.4/0.3/Data/Functor/Sum.hs0000644000000000000000000000741112646607327017764 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif # if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} # endif #endif -- | -- Module : Data.Functor.Sum -- Copyright : (c) Ross Paterson 2014 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : ross@soi.city.ac.uk -- Stability : experimental -- Portability : portable -- -- Sums, lifted to functors. module Data.Functor.Sum ( Sum(..), ) where import Control.Applicative import Data.Foldable (Foldable(foldMap)) import Data.Functor.Classes import Data.Monoid (mappend) import Data.Traversable (Traversable(traverse)) #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 702 import GHC.Generics # endif # if __GLASGOW_HASKELL__ >= 708 import Data.Data # endif #endif -- | Lifted sum of functors. data Sum f g a = InL (f a) | InR (g a) #ifndef HASKELL98 # if __GLASGOW_HASKELL__ >= 702 deriving instance Generic (Sum f g a) instance Generic1 (Sum f g) where type Rep1 (Sum f g) = D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f)) :+: C1 MCInR (S1 NoSelector (Rec1 g))) from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f)))) from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g)))) to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f) to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) data MDSum data MCInL data MCInR instance Datatype MDSum where datatypeName _ = "Sum" moduleName _ = "Data.Functor.Sum" instance Constructor MCInL where conName _ = "InL" instance Constructor MCInR where conName _ = "InR" # endif # if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable Sum deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) # endif #endif instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 liftEq _ (InL _) (InR _) = False liftEq _ (InR _) (InL _) = False liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 liftCompare _ (InL _) (InR _) = LT liftCompare _ (InR _) (InL _) = GT liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 instance (Read1 f, Read1 g) => Read1 (Sum f g) where liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` readsUnaryWith (liftReadsPrec rp rl) "InR" InR instance (Show1 f, Show1 g) => Show1 (Sum f g) where liftShowsPrec sp sl d (InL x) = showsUnaryWith (liftShowsPrec sp sl) "InL" d x liftShowsPrec sp sl d (InR y) = showsUnaryWith (liftShowsPrec sp sl) "InR" d y instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where (==) = eq1 instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where compare = compare1 instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where readsPrec = readsPrec1 instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where showsPrec = showsPrec1 instance (Functor f, Functor g) => Functor (Sum f g) where fmap f (InL x) = InL (fmap f x) fmap f (InR y) = InR (fmap f y) instance (Foldable f, Foldable g) => Foldable (Sum f g) where foldMap f (InL x) = foldMap f x foldMap f (InR y) = foldMap f y instance (Traversable f, Traversable g) => Traversable (Sum f g) where traverse f (InL x) = InL <$> traverse f x traverse f (InR y) = InR <$> traverse f y transformers-compat-0.5.1.4/src/0000755000000000000000000000000012646607327014657 5ustar0000000000000000transformers-compat-0.5.1.4/src/Control/0000755000000000000000000000000012646607327016277 5ustar0000000000000000transformers-compat-0.5.1.4/src/Control/Monad/0000755000000000000000000000000012646607327017335 5ustar0000000000000000transformers-compat-0.5.1.4/src/Control/Monad/Trans/0000755000000000000000000000000012646607327020424 5ustar0000000000000000transformers-compat-0.5.1.4/src/Control/Monad/Trans/Instances.hs0000644000000000000000000003102612646607327022711 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef HASKELL98 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} # if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Trustworthy #-} # endif # if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} # endif # if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DataKinds #-} # endif #endif {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- 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 Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Cont (ContT(..)) import Control.Monad.Trans.Error (ErrorT(..)) import Control.Monad.Trans.Except () import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..)) import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import 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 () import Control.Applicative import Control.Monad (MonadPlus(..)) import Control.Monad.Fix (MonadFix(..)) import Data.Foldable (Foldable(..)) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(..)) #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip (MonadZip(..)) #endif #if MIN_VERSION_base(4,8,0) import Data.Bifunctor (Bifunctor(..)) #endif #ifndef HASKELL98 import Data.Data (Data) import Data.Typeable # if __GLASGOW_HASKELL__ >= 702 import GHC.Generics # endif #endif #if !(MIN_VERSION_transformers(0,3,0)) -- Foldable/Traversable instances instance (Foldable f) => Foldable (ErrorT e f) where foldMap f (ErrorT a) = foldMap (either (const mempty) f) a instance (Traversable f) => Traversable (ErrorT e f) where traverse f (ErrorT a) = ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a instance (Foldable f) => Foldable (IdentityT f) where foldMap f (IdentityT a) = foldMap f a instance (Traversable f) => Traversable (IdentityT f) where traverse f (IdentityT a) = IdentityT <$> traverse f a instance (Foldable f) => Foldable (ListT f) where foldMap f (ListT a) = foldMap (foldMap f) a instance (Traversable f) => Traversable (ListT f) where traverse f (ListT a) = ListT <$> traverse (traverse f) a instance (Foldable f) => Foldable (MaybeT f) where foldMap f (MaybeT a) = foldMap (foldMap f) a instance (Traversable f) => Traversable (MaybeT f) where traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a instance (Foldable f) => Foldable (Lazy.WriterT w f) where foldMap f = foldMap (f . fst) . Lazy.runWriterT instance (Traversable f) => Traversable (Lazy.WriterT w f) where traverse f = fmap Lazy.WriterT . traverse f' . Lazy.runWriterT where f' (a, b) = fmap (\ c -> (c, b)) (f a) instance (Foldable f) => Foldable (Strict.WriterT w f) where foldMap f = foldMap (f . fst) . Strict.runWriterT instance (Traversable f) => Traversable (Strict.WriterT w f) where traverse f = fmap Strict.WriterT . traverse f' . Strict.runWriterT where f' (a, b) = fmap (\ c -> (c, b)) (f a) -- MonadFix instances for IdentityT and MaybeT instance (MonadFix m) => MonadFix (IdentityT m) where mfix f = IdentityT (mfix (runIdentityT . f)) instance (MonadFix m) => MonadFix (MaybeT m) where mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb)) where bomb = error "mfix (MaybeT): inner computation returned Nothing" # if !(MIN_VERSION_base(4,9,0)) -- Monad instances for Product instance (Monad f, Monad g) => Monad (Product f g) where return x = Pair (return x) (return x) Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) where fstP (Pair a _) = a sndP (Pair _ b) = b 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)) -- 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__ >= 702 instance Generic (Identity a) where type Rep (Identity a) = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity (Rec0 a))) from (Identity x) = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = Identity x instance Generic1 Identity where type Rep1 Identity = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity Par1)) from1 (Identity x) = M1 (M1 (M1 (Par1 x))) to1 (M1 (M1 (M1 x))) = Identity (unPar1 x) data MDIdentity data MCIdentity data MSIdentity instance Datatype MDIdentity where datatypeName _ = "Identity" moduleName _ = "Data.Functor.Identity" # if __GLASGOW_HASKELL__ >= 708 isNewtype _ = True # endif instance Constructor MCIdentity where conName _ = "Identity" conIsRecord _ = True instance Selector MSIdentity where selName _ = "runIdentity" # endif # if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable 'Identity # endif # endif # if !(MIN_VERSION_base(4,9,0)) # if __GLASGOW_HASKELL__ >= 702 -- Generic(1) instances for Compose instance Generic (Compose f g a) where type Rep (Compose f g a) = 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" # endif # if __GLASGOW_HASKELL__ >= 708 -- Data instances for Compose and Product deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) => Data (Product (f :: * -> *) (g :: * -> *) (a :: *)) # endif # endif # endif #endif