contravariant 1.4.1 → 1.5.6
raw patch · 11 files changed
Files
- .hlint.yaml +6/−0
- .travis.yml +0/−155
- CHANGELOG.markdown +32/−0
- HLint.hs +0/−3
- README.markdown +1/−1
- contravariant.cabal +37/−56
- old-src/Data/Functor/Contravariant.hs +400/−0
- src/Data/Functor/Contravariant.hs +0/−458
- src/Data/Functor/Contravariant/Compose.hs +1/−4
- src/Data/Functor/Contravariant/Divisible.hs +38/−51
- src/Data/Functor/Contravariant/Generic.hs +59/−38
+ .hlint.yaml view
@@ -0,0 +1,6 @@+- arguments: [-XCPP, --cpp-define=HLINT, --cpp-define=GHC_GENERICS, --cpp-ansi]++- ignore: {name: Eta reduce}+- ignore: {name: Use const}+- ignore: {name: Use first}+- ignore: {name: Use void, within: [Data.Functor.Contravariant]}
− .travis.yml
@@ -1,155 +0,0 @@-# This Travis job script has been generated by a script via-#-# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project'-#-# For more information, see https://github.com/hvr/multi-ghc-travis-#-language: c-sudo: false--git:- submodules: false # whether to recursively clone submodules--notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313contravariant\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"--cache:- directories:- - $HOME/.cabal/packages- - $HOME/.cabal/store--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- # remove files that are regenerated by 'cabal update'- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx-- - rm -rfv $HOME/.cabal/packages/head.hackage--addons:- apt:- packages: &apt_packages- - ghc-ppa-tools- - hlint--matrix:- include:- - compiler: "ghc-7.0.4"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}- - compiler: "ghc-7.2.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}}- - compiler: "ghc-7.4.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}- - compiler: "ghc-7.6.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}- - compiler: "ghc-7.8.4"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}- - compiler: "ghc-7.10.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}- - compiler: "ghc-8.0.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}- - compiler: "ghc-8.2.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}- - compiler: "ghc-8.4.1"- env: GHCHEAD=true- addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}- - compiler: "ghc-head"- env: GHCHEAD=true- addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}}-- allow_failures:- - compiler: "ghc-7.0.4"- - compiler: "ghc-7.2.2"- - compiler: "ghc-8.4.1"- - compiler: "ghc-head"--before_install:- - HC=${CC}- - HCPKG=${HC/ghc/ghc-pkg}- - unset CC- - ROOTDIR=$(pwd)- - mkdir -p $HOME/.local/bin- - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"- - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))- - echo $HCNUMVER--install:- - cabal --version- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"- - BENCH=${BENCH---enable-benchmarks}- - TEST=${TEST---enable-tests}- - HADDOCK=${HADDOCK-true}- - INSTALLED=${INSTALLED-true}- - GHCHEAD=${GHCHEAD-false}- - travis_retry cabal update -v- - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"- - rm -fv cabal.project cabal.project.local- # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage- - |- if $GHCHEAD; then- sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config-- echo 'repository head.hackage' >> ${HOME}/.cabal/config- echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config- echo ' secure: True' >> ${HOME}/.cabal/config- echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config- echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config- echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config- echo ' key-threshold: 3' >> ${HOME}/.cabal.config-- cabal new-update head.hackage -v- fi- - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'- - "printf 'packages: \".\"\\n' > cabal.project"- - cat cabal.project- - if [ -f "./configure.ac" ]; then- (cd "." && autoreconf -i);- fi- - rm -f cabal.project.freeze- - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all- - rm -rf "."/.ghc.environment.* "."/dist- - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)--# Here starts the actual work to be performed for the package under test;-# any command which exits with a non-zero exit code causes the build to fail.-script:- # test that source-distributions can be generated- - (cd "." && cabal sdist)- - mv "."/dist/contravariant-*.tar.gz ${DISTDIR}/- - cd ${DISTDIR} || false- - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;- - "printf 'packages: contravariant-*/*.cabal\\n' > cabal.project"- - cat cabal.project--- # build & run tests, build benchmarks- - cabal new-build -w ${HC} ${TEST} ${BENCH} all-- # cabal check- - (cd contravariant-* && cabal check)-- # haddock- - rm -rf ./dist-newstyle- - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi-- # hlint- - (cd contravariant-* && hlint src --cpp-define=HLINT)--# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"]-# EOF
CHANGELOG.markdown view
@@ -1,3 +1,35 @@+1.5.6 [2026.01.10]+------------------+* Drop support for pre-8.0 versions of GHC.+* Support building with MicroHs.++1.5.5 [2021.07.27]+------------------+* Fix the build on old GHCs using `transformers-0.6.*`.++1.5.4 [2021.07.25]+------------------+* Allow building with `transformers-0.6.*`.++1.5.3 [2020.12.30]+------------------+* Explicitly mark modules as `Safe`.++1.5.2 [2019.06.03]+------------------+* Mark `Data.Functor.Contravariant` and `Data.Functor.Contravariant.Generic`+ as unconditionally `Trustworthy`.++1.5.1 [2019.05.02]+------------------+* Remove the use of `unsafeCoerce` in `Data.Functor.Contravariant.Generic`. As+ a result, the `safe` flag has been removed, as it is no longer used.++1.5 [2018.07.01]+----------------+* Support building with GHC 8.6, where `Data.Functor.Contravariant` has been+ moved into `base`.+ 1.4.1 [2018.01.18] ------------------ * Add `Semigroup` and `Monoid` instances for `Predicate`.
− HLint.hs
@@ -1,3 +0,0 @@-ignore "Eta reduce"-ignore "Use const"-ignore "Use first"
README.markdown view
@@ -2,7 +2,7 @@ ============= [](https://hackage.haskell.org/package/contravariant)-[](http://travis-ci.org/ekmett/contravariant)+[](https://github.com/ekmett/contravariant/actions?query=workflow%3AHaskell-CI) Haskell 98 contravariant functors
contravariant.cabal view
@@ -1,8 +1,8 @@ name: contravariant category: Control, Data-version: 1.4.1+version: 1.5.6 license: BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -13,45 +13,28 @@ synopsis: Contravariant functors description: Contravariant functors. build-type: Simple-tested-with: GHC == 7.0.4- , GHC == 7.2.2- , GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2+tested-with: GHC == 8.0.2 , GHC == 8.2.2- , GHC == 8.4.1+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 extra-source-files:- .travis.yml+ .hlint.yaml CHANGELOG.markdown README.markdown- HLint.hs source-repository head type: git- location: git://github.com/ekmett/contravariant.git--flag tagged- description:- You can disable the use of the `tagged` package using `-f-tagged`.- .- Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- default: True- manual: True--flag semigroups- description:- You can disable the use of the `semigroups` package using `-f-semigroups`.- .- Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.- default: True- manual: True--flag safe- description: Get Safe guarantees rather than merely Trustworthy, but with worse constant factors.- default: False- manual: True+ location: https://github.com/ekmett/contravariant.git flag StateVar description:@@ -64,34 +47,32 @@ library hs-source-dirs: src build-depends:- base < 5,- transformers >= 0.2 && < 0.6,- transformers-compat >= 0.3 && < 1-- if !impl(ghc >= 7.9)- build-depends: void >= 0.6 && < 1-- if flag(tagged) && !impl(ghc >= 7.7)- build-depends: tagged >= 0.4.4 && < 1-- if flag(semigroups) && !impl(ghc >= 7.11)- build-depends: semigroups >= 0.15.2 && < 1+ base >= 4.9 && < 5,+ transformers >= 0.3 && < 0.7 if flag(StateVar)- build-depends: StateVar >= 1.1 && < 1.2-- if impl(ghc >= 7.2 && < 7.6)- build-depends: ghc-prim-- if flag(safe)- cpp-options: -DSAFE+ build-depends: StateVar >= 1.2.1 && < 1.3 exposed-modules:- Data.Functor.Contravariant Data.Functor.Contravariant.Compose Data.Functor.Contravariant.Divisible - if impl(ghc >= 7.4)- exposed-modules: Data.Functor.Contravariant.Generic+ if impl(ghc)+ -- MicroHs doesn't support type families yet+ exposed-modules:+ Data.Functor.Contravariant.Generic + if impl(ghc < 8.5)+ hs-source-dirs: old-src+ exposed-modules: Data.Functor.Contravariant++ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type++ if impl(ghc >= 9.0)+ -- these flags may abort compilation with GHC-8.10+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+ ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode+ ghc-options: -Wall+ default-language: Haskell2010
+ old-src/Data/Functor/Contravariant.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeOperators #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -Wno-deprecations #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Contravariant+-- Copyright : (C) 2007-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,+-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'+-- the definition of 'Contravariant' for a given ADT is unambiguous.+----------------------------------------------------------------------------++module Data.Functor.Contravariant (+ -- * Contravariant Functors+ Contravariant(..)+ , phantom++ -- * Operators+ , (>$<), (>$$<), ($<)++ -- * Predicates+ , Predicate(..)++ -- * Comparisons+ , Comparison(..)+ , defaultComparison++ -- * Equivalence Relations+ , Equivalence(..)+ , defaultEquivalence+ , comparisonEquivalence++ -- * Dual arrows+ , Op(..)+ ) where++import Control.Applicative+import Control.Applicative.Backwards++import Control.Category++import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Function (on)++import Data.Functor.Product+import Data.Functor.Sum+import Data.Functor.Constant+import Data.Functor.Compose+import Data.Functor.Reverse++import Data.Monoid (Alt(..))+import Data.Proxy (Proxy(..))+import Data.Semigroup (Semigroup(..))++import GHC.Generics++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++import Prelude hiding ((.),id)++-- | The class of contravariant functors.+--+-- Whereas in Haskell, one can think of a 'Functor' as containing or producing+-- values, a contravariant functor is a functor that can be thought of as+-- /consuming/ values.+--+-- As an example, consider the type of predicate functions @a -> Bool@. One+-- such predicate might be @negative x = x < 0@, which+-- classifies integers as to whether they are negative. However, given this+-- predicate, we can re-use it in other situations, providing we have a way to+-- map values /to/ integers. For instance, we can use the @negative@ predicate+-- on a person's bank balance to work out if they are currently overdrawn:+--+-- @+-- newtype Predicate a = Predicate { getPredicate :: a -> Bool }+--+-- instance Contravariant Predicate where+-- contramap f (Predicate p) = Predicate (p . f)+-- | `- First, map the input...+-- `----- then apply the predicate.+--+-- overdrawn :: Predicate Person+-- overdrawn = contramap personBankBalance negative+-- @+--+-- Any instance should be subject to the following laws:+--+-- > contramap id = id+-- > contramap f . contramap g = contramap (g . f)+--+-- Note, that the second law follows from the free theorem of the type of+-- 'contramap' and the first law, so you need only check that the former+-- condition holds.++class Contravariant f where+ contramap :: (a -> b) -> f b -> f a++ -- | Replace all locations in the output with the same value.+ -- The default definition is @'contramap' . 'const'@, but this may be+ -- overridden with a more efficient version.+ (>$) :: b -> f b -> f a+ (>$) = contramap . const++-- | If 'f' is both 'Functor' and 'Contravariant' then by the time you factor in the laws+-- of each of those classes, it can't actually use its argument in any meaningful capacity.+--+-- This method is surprisingly useful. Where both instances exist and are lawful we have+-- the following laws:+--+-- @+-- 'fmap' f ≡ 'phantom'+-- 'contramap' f ≡ 'phantom'+-- @+phantom :: (Functor f, Contravariant f) => f a -> f b+phantom x = () <$ x $< ()++infixl 4 >$, $<, >$<, >$$<++-- | This is '>$' with its arguments flipped.+($<) :: Contravariant f => f b -> b -> f a+($<) = flip (>$)+{-# INLINE ($<) #-}++-- | This is an infix alias for 'contramap'.+(>$<) :: Contravariant f => (a -> b) -> f b -> f a+(>$<) = contramap+{-# INLINE (>$<) #-}++-- | This is an infix version of 'contramap' with the arguments flipped.+(>$$<) :: Contravariant f => f b -> (a -> b) -> f a+(>$$<) = flip contramap+{-# INLINE (>$$<) #-}++instance Contravariant f => Contravariant (Alt f) where+ contramap f = Alt . contramap f . getAlt++instance Contravariant V1 where+ contramap _ x = x `seq` undefined++instance Contravariant U1 where+ contramap _ _ = U1++instance Contravariant f => Contravariant (Rec1 f) where+ contramap f (Rec1 fp)= Rec1 (contramap f fp)++instance Contravariant f => Contravariant (M1 i c f) where+ contramap f (M1 fp) = M1 (contramap f fp)++instance Contravariant (K1 i c) where+ contramap _ (K1 c) = K1 c++instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where+ contramap f (xs :*: ys) = contramap f xs :*: contramap f ys++instance (Functor f, Contravariant g) => Contravariant (f :.: g) where+ contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)+ {-# INLINE contramap #-}++instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where+ contramap f (L1 xs) = L1 (contramap f xs)+ contramap f (R1 ys) = R1 (contramap f ys)++instance Contravariant m => Contravariant (ExceptT e m) where+ contramap f = ExceptT . contramap (fmap f) . runExceptT++instance Contravariant f => Contravariant (IdentityT f) where+ contramap f = IdentityT . contramap f . runIdentityT++instance Contravariant m => Contravariant (MaybeT m) where+ contramap f = MaybeT . contramap (fmap f) . runMaybeT++instance Contravariant m => Contravariant (Lazy.RWST r w s m) where+ contramap f m = Lazy.RWST $ \r s ->+ contramap (\ ~(a, s', w) -> (f a, s', w)) $ Lazy.runRWST m r s++instance Contravariant m => Contravariant (Strict.RWST r w s m) where+ contramap f m = Strict.RWST $ \r s ->+ contramap (\ (a, s', w) -> (f a, s', w)) $ Strict.runRWST m r s++instance Contravariant m => Contravariant (ReaderT r m) where+ contramap f = ReaderT . fmap (contramap f) . runReaderT++instance Contravariant m => Contravariant (Lazy.StateT s m) where+ contramap f m = Lazy.StateT $ \s ->+ contramap (\ ~(a, s') -> (f a, s')) $ Lazy.runStateT m s++instance Contravariant m => Contravariant (Strict.StateT s m) where+ contramap f m = Strict.StateT $ \s ->+ contramap (\ (a, s') -> (f a, s')) $ Strict.runStateT m s++instance Contravariant m => Contravariant (Lazy.WriterT w m) where+ contramap f = Lazy.mapWriterT $ contramap $ \ ~(a, w) -> (f a, w)++instance Contravariant m => Contravariant (Strict.WriterT w m) where+ contramap f = Strict.mapWriterT $ contramap $ \ (a, w) -> (f a, w)++instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where+ contramap f (InL xs) = InL (contramap f xs)+ contramap f (InR ys) = InR (contramap f ys)++instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where+ contramap f (Pair a b) = Pair (contramap f a) (contramap f b)++instance Contravariant (Constant a) where+ contramap _ (Constant a) = Constant a++instance Contravariant (Const a) where+ contramap _ (Const a) = Const a++instance (Functor f, Contravariant g) => Contravariant (Compose f g) where+ contramap f (Compose fga) = Compose (fmap (contramap f) fga)+ {-# INLINE contramap #-}++instance Contravariant f => Contravariant (Backwards f) where+ contramap f = Backwards . contramap f . forwards+ {-# INLINE contramap #-}++instance Contravariant f => Contravariant (Reverse f) where+ contramap f = Reverse . contramap f . getReverse+ {-# INLINE contramap #-}++#if !(MIN_VERSION_transformers(0,6,0))+instance Contravariant m => Contravariant (ErrorT e m) where+ contramap f = ErrorT . contramap (fmap f) . runErrorT++instance Contravariant m => Contravariant (ListT m) where+ contramap f = ListT . contramap (fmap f) . runListT+#endif++#ifdef MIN_VERSION_StateVar+instance Contravariant SettableStateVar where+ contramap f (SettableStateVar k) = SettableStateVar (k . f)+ {-# INLINE contramap #-}+#endif++instance Contravariant Proxy where+ contramap _ _ = Proxy++newtype Predicate a = Predicate { getPredicate :: a -> Bool }++-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can+-- apply its function argument to the input of the predicate.+instance Contravariant Predicate where+ contramap f g = Predicate $ getPredicate g . f++instance Semigroup (Predicate a) where+ Predicate p <> Predicate q = Predicate $ \a -> p a && q a++instance Monoid (Predicate a) where+ mempty = Predicate $ const True+ mappend = (<>)++-- | Defines a total ordering on a type as per 'compare'.+--+-- This condition is not checked by the types. You must ensure that the supplied+-- values are valid total orderings yourself.+newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }++-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can+-- apply its function argument to each input of the comparison function.+instance Contravariant Comparison where+ contramap f g = Comparison $ on (getComparison g) f++instance Semigroup (Comparison a) where+ Comparison p <> Comparison q = Comparison $ mappend p q++instance Monoid (Comparison a) where+ mempty = Comparison (\_ _ -> EQ)+ mappend (Comparison p) (Comparison q) = Comparison $ mappend p q++-- | Compare using 'compare'.+defaultComparison :: Ord a => Comparison a+defaultComparison = Comparison compare++-- | This data type represents an equivalence relation.+--+-- Equivalence relations are expected to satisfy three laws:+--+-- __Reflexivity__:+--+-- @+-- 'getEquivalence' f a a = True+-- @+--+-- __Symmetry__:+--+-- @+-- 'getEquivalence' f a b = 'getEquivalence' f b a+-- @+--+-- __Transitivity__:+--+-- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' then so is @'getEquivalence' f a c@+--+-- The types alone do not enforce these laws, so you'll have to check them yourself.+newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }++-- | Equivalence relations are 'Contravariant', because you can+-- apply the contramapped function to each input to the equivalence+-- relation.+instance Contravariant Equivalence where+ contramap f g = Equivalence $ on (getEquivalence g) f++instance Semigroup (Equivalence a) where+ Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b++instance Monoid (Equivalence a) where+ mempty = Equivalence (\_ _ -> True)+ mappend (Equivalence p) (Equivalence q) = Equivalence $ \a b -> p a b && q a b++-- | Check for equivalence with '=='.+--+-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.+defaultEquivalence :: Eq a => Equivalence a+defaultEquivalence = Equivalence (==)++comparisonEquivalence :: Comparison a -> Equivalence a+comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ++-- | Dual function arrows.+newtype Op a b = Op { getOp :: b -> a }++instance Category Op where+ id = Op id+ Op f . Op g = Op (g . f)++instance Contravariant (Op a) where+ contramap f g = Op (getOp g . f)++instance Semigroup a => Semigroup (Op a b) where+ Op p <> Op q = Op $ \a -> p a <> q a++instance Monoid a => Monoid (Op a b) where+ mempty = Op (const mempty)+ mappend (Op p) (Op q) = Op $ \a -> mappend (p a) (q a)++instance Num a => Num (Op a b) where+ Op f + Op g = Op $ \a -> f a + g a+ Op f * Op g = Op $ \a -> f a * g a+ Op f - Op g = Op $ \a -> f a - g a+ abs (Op f) = Op $ abs . f+ signum (Op f) = Op $ signum . f+ fromInteger = Op . const . fromInteger++instance Fractional a => Fractional (Op a b) where+ Op f / Op g = Op $ \a -> f a / g a+ recip (Op f) = Op $ recip . f+ fromRational = Op . const . fromRational++instance Floating a => Floating (Op a b) where+ pi = Op $ const pi+ exp (Op f) = Op $ exp . f+ sqrt (Op f) = Op $ sqrt . f+ log (Op f) = Op $ log . f+ sin (Op f) = Op $ sin . f+ tan (Op f) = Op $ tan . f+ cos (Op f) = Op $ cos . f+ asin (Op f) = Op $ asin . f+ atan (Op f) = Op $ atan . f+ acos (Op f) = Op $ acos . f+ sinh (Op f) = Op $ sinh . f+ tanh (Op f) = Op $ tanh . f+ cosh (Op f) = Op $ cosh . f+ asinh (Op f) = Op $ asinh . f+ atanh (Op f) = Op $ atanh . f+ acosh (Op f) = Op $ acosh . f+ Op f ** Op g = Op $ \a -> f a ** g a+ logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)
− src/Data/Functor/Contravariant.hs
@@ -1,458 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}--#ifdef __GLASGOW_HASKELL__-#define LANGUAGE_DeriveDataTypeable-{-# LANGUAGE DeriveDataTypeable #-}-#endif--#ifndef MIN_VERSION_tagged-#define MIN_VERSION_tagged(x,y,z) 1-#endif--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--#if __GLASGOW_HASKELL__ >= 704-#if MIN_VERSION_transformers(0,3,0) && MIN_VERSION_tagged(0,6,1)-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif-#endif--{-# OPTIONS_GHC -fno-warn-deprecations #-}---------------------------------------------------------------------------------- |--- Module : Data.Functor.Contravariant--- Copyright : (C) 2007-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,--- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'--- the definition of 'Contravariant' for a given ADT is unambiguous.-------------------------------------------------------------------------------module Data.Functor.Contravariant (- -- * Contravariant Functors- Contravariant(..)- , phantom-- -- * Operators- , (>$<), (>$$<), ($<)-- -- * Predicates- , Predicate(..)-- -- * Comparisons- , Comparison(..)- , defaultComparison-- -- * Equivalence Relations- , Equivalence(..)- , defaultEquivalence- , comparisonEquivalence-- -- * Dual arrows- , Op(..)- ) where--import Control.Applicative-import Control.Applicative.Backwards--import Control.Category--import Control.Monad.Trans.Error-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity-import Control.Monad.Trans.List-import Control.Monad.Trans.Maybe-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import Control.Monad.Trans.Reader-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Strict as Strict--import Data.Function (on)--import Data.Functor.Product-import Data.Functor.Sum-import Data.Functor.Constant-import Data.Functor.Compose-import Data.Functor.Reverse--#if MIN_VERSION_base(4,8,0)-import Data.Monoid (Alt(..))-#else-import Data.Monoid (Monoid(..))-#endif--#if defined(MIN_VERSION_semigroups) || __GLASGOW_HASKELL__ >= 711-import Data.Semigroup (Semigroup(..))-#endif--#ifdef LANGUAGE_DeriveDataTypeable-import Data.Typeable-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 && defined(VERSION_tagged)-import Data.Proxy-#endif--#ifdef MIN_VERSION_StateVar-import Data.StateVar-#endif--#if __GLASGOW_HASKELL__ >= 702-#define GHC_GENERICS-import GHC.Generics-#endif--import Prelude hiding ((.),id)---- | The class of contravariant functors.------ Whereas in Haskell, one can think of a 'Functor' as containing or producing--- values, a contravariant functor is a functor that can be thought of as--- /consuming/ values.------ As an example, consider the type of predicate functions @a -> Bool@. One--- such predicate might be @negative x = x < 0@, which--- classifies integers as to whether they are negative. However, given this--- predicate, we can re-use it in other situations, providing we have a way to--- map values /to/ integers. For instance, we can use the @negative@ predicate--- on a person's bank balance to work out if they are currently overdrawn:------ @--- newtype Predicate a = Predicate { getPredicate :: a -> Bool }------ instance Contravariant Predicate where--- contramap f (Predicate p) = Predicate (p . f)--- | `- First, map the input...--- `----- then apply the predicate.------ overdrawn :: Predicate Person--- overdrawn = contramap personBankBalance negative--- @------ Any instance should be subject to the following laws:------ > contramap id = id--- > contramap f . contramap g = contramap (g . f)------ Note, that the second law follows from the free theorem of the type of--- 'contramap' and the first law, so you need only check that the former--- condition holds.--class Contravariant f where- contramap :: (a -> b) -> f b -> f a-- -- | Replace all locations in the output with the same value.- -- The default definition is @'contramap' . 'const'@, but this may be- -- overridden with a more efficient version.- (>$) :: b -> f b -> f a- (>$) = contramap . const---- | If 'f' is both 'Functor' and 'Contravariant' then by the time you factor in the laws--- of each of those classes, it can't actually use its argument in any meaningful capacity.------ This method is surprisingly useful. Where both instances exist and are lawful we have--- the following laws:------ @--- 'fmap' f ≡ 'phantom'--- 'contramap' f ≡ 'phantom'--- @-phantom :: (Functor f, Contravariant f) => f a -> f b-phantom x = () <$ x $< ()--infixl 4 >$, $<, >$<, >$$<---- | This is '>$' with its arguments flipped.-($<) :: Contravariant f => f b -> b -> f a-($<) = flip (>$)-{-# INLINE ($<) #-}---- | This is an infix alias for 'contramap'-(>$<) :: Contravariant f => (a -> b) -> f b -> f a-(>$<) = contramap-{-# INLINE (>$<) #-}---- | This is an infix version of 'contramap' with the arguments flipped.-(>$$<) :: Contravariant f => f b -> (a -> b) -> f a-(>$$<) = flip contramap-{-# INLINE (>$$<) #-}--#if MIN_VERSION_base(4,8,0)-instance Contravariant f => Contravariant (Alt f) where- contramap f = Alt . contramap f . getAlt-#endif--#ifdef GHC_GENERICS-instance Contravariant V1 where- contramap _ x = x `seq` undefined--instance Contravariant U1 where- contramap _ U1 = U1--instance Contravariant f => Contravariant (Rec1 f) where- contramap f (Rec1 fp)= Rec1 (contramap f fp)--instance Contravariant f => Contravariant (M1 i c f) where- contramap f (M1 fp) = M1 (contramap f fp)--instance Contravariant (K1 i c) where- contramap _ (K1 c) = K1 c--instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where- contramap f (xs :*: ys) = contramap f xs :*: contramap f ys--instance (Functor f, Contravariant g) => Contravariant (f :.: g) where- contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)- {-# INLINE contramap #-}--instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where- contramap f (L1 xs) = L1 (contramap f xs)- contramap f (R1 ys) = R1 (contramap f ys)-#endif--instance Contravariant m => Contravariant (ErrorT e m) where- contramap f = ErrorT . contramap (fmap f) . runErrorT--instance Contravariant m => Contravariant (ExceptT e m) where- contramap f = ExceptT . contramap (fmap f) . runExceptT--instance Contravariant f => Contravariant (IdentityT f) where- contramap f = IdentityT . contramap f . runIdentityT--instance Contravariant m => Contravariant (ListT m) where- contramap f = ListT . contramap (fmap f) . runListT--instance Contravariant m => Contravariant (MaybeT m) where- contramap f = MaybeT . contramap (fmap f) . runMaybeT--instance Contravariant m => Contravariant (Lazy.RWST r w s m) where- contramap f m = Lazy.RWST $ \r s ->- contramap (\ ~(a, s', w) -> (f a, s', w)) $ Lazy.runRWST m r s--instance Contravariant m => Contravariant (Strict.RWST r w s m) where- contramap f m = Strict.RWST $ \r s ->- contramap (\ (a, s', w) -> (f a, s', w)) $ Strict.runRWST m r s--instance Contravariant m => Contravariant (ReaderT r m) where- contramap f = ReaderT . fmap (contramap f) . runReaderT--instance Contravariant m => Contravariant (Lazy.StateT s m) where- contramap f m = Lazy.StateT $ \s ->- contramap (\ ~(a, s') -> (f a, s')) $ Lazy.runStateT m s--instance Contravariant m => Contravariant (Strict.StateT s m) where- contramap f m = Strict.StateT $ \s ->- contramap (\ (a, s') -> (f a, s')) $ Strict.runStateT m s--instance Contravariant m => Contravariant (Lazy.WriterT w m) where- contramap f = Lazy.mapWriterT $ contramap $ \ ~(a, w) -> (f a, w)--instance Contravariant m => Contravariant (Strict.WriterT w m) where- contramap f = Strict.mapWriterT $ contramap $ \ (a, w) -> (f a, w)--instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where- contramap f (InL xs) = InL (contramap f xs)- contramap f (InR ys) = InR (contramap f ys)--instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where- contramap f (Pair a b) = Pair (contramap f a) (contramap f b)--instance Contravariant (Constant a) where- contramap _ (Constant a) = Constant a--instance Contravariant (Const a) where- contramap _ (Const a) = Const a--instance (Functor f, Contravariant g) => Contravariant (Compose f g) where- contramap f (Compose fga) = Compose (fmap (contramap f) fga)- {-# INLINE contramap #-}--instance Contravariant f => Contravariant (Backwards f) where- contramap f = Backwards . contramap f . forwards- {-# INLINE contramap #-}--instance Contravariant f => Contravariant (Reverse f) where- contramap f = Reverse . contramap f . getReverse- {-# INLINE contramap #-}--#ifdef MIN_VERSION_StateVar-instance Contravariant SettableStateVar where- contramap f (SettableStateVar k) = SettableStateVar (k . f)- {-# INLINE contramap #-}-#endif--#if (__GLASGOW_HASKELL__ >= 707) || defined(VERSION_tagged)-instance Contravariant Proxy where- contramap _ Proxy = Proxy-#endif--newtype Predicate a = Predicate { getPredicate :: a -> Bool }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif---- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to the input of the predicate.-instance Contravariant Predicate where- contramap f g = Predicate $ getPredicate g . f--#if defined(MIN_VERSION_semigroups) || __GLASGOW_HASKELL__ >= 711-instance Semigroup (Predicate a) where- Predicate p <> Predicate q = Predicate $ \a -> p a && q a-#endif--instance Monoid (Predicate a) where- mempty = Predicate $ const True-#if defined(MIN_VERSION_semigroups) || __GLASGOW_HASKELL__ >= 711- mappend = (<>)-#else- mappend (Predicate p) (Predicate q) = Predicate $ \a -> p a && q a-#endif---- | Defines a total ordering on a type as per 'compare'------ This condition is not checked by the types. You must ensure that the supplied--- values are valid total orderings yourself.-newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif---- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to each input of the comparison function.-instance Contravariant Comparison where- contramap f g = Comparison $ on (getComparison g) f--#if defined(MIN_VERSION_semigroups) || __GLASGOW_HASKELL__ >= 711-instance Semigroup (Comparison a) where- Comparison p <> Comparison q = Comparison $ mappend p q-#endif--instance Monoid (Comparison a) where- mempty = Comparison (\_ _ -> EQ)- mappend (Comparison p) (Comparison q) = Comparison $ mappend p q---- | Compare using 'compare'-defaultComparison :: Ord a => Comparison a-defaultComparison = Comparison compare---- | This data type represents an equivalence relation.------ Equivalence relations are expected to satisfy three laws:------ __Reflexivity__:------ @--- 'getEquivalence' f a a = True--- @------ __Symmetry__:------ @--- 'getEquivalence' f a b = 'getEquivalence' f b a--- @------ __Transitivity__:------ If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' then so is @'getEquivalence' f a c@------ The types alone do not enforce these laws, so you'll have to check them yourself.-newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif---- | Equivalence relations are 'Contravariant', because you can--- apply the contramapped function to each input to the equivalence--- relation.-instance Contravariant Equivalence where- contramap f g = Equivalence $ on (getEquivalence g) f--#if defined(MIN_VERSION_semigroups) || __GLASGOW_HASKELL__ >= 711-instance Semigroup (Equivalence a) where- Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b-#endif--instance Monoid (Equivalence a) where- mempty = Equivalence (\_ _ -> True)- mappend (Equivalence p) (Equivalence q) = Equivalence $ \a b -> p a b && q a b---- | Check for equivalence with '=='------ Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.-defaultEquivalence :: Eq a => Equivalence a-defaultEquivalence = Equivalence (==)--comparisonEquivalence :: Comparison a -> Equivalence a-comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ---- | Dual function arrows.-newtype Op a b = Op { getOp :: b -> a }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif--instance Category Op where- id = Op id- Op f . Op g = Op (g . f)--instance Contravariant (Op a) where- contramap f g = Op (getOp g . f)--#if defined(MIN_VERSION_semigroups) || __GLASGOW_HASKELL__ >= 711-instance Semigroup a => Semigroup (Op a b) where- Op p <> Op q = Op $ \a -> p a <> q a-#endif--instance Monoid a => Monoid (Op a b) where- mempty = Op (const mempty)- mappend (Op p) (Op q) = Op $ \a -> mappend (p a) (q a)--#if MIN_VERSION_base(4,5,0)-instance Num a => Num (Op a b) where- Op f + Op g = Op $ \a -> f a + g a- Op f * Op g = Op $ \a -> f a * g a- Op f - Op g = Op $ \a -> f a - g a- abs (Op f) = Op $ abs . f- signum (Op f) = Op $ signum . f- fromInteger = Op . const . fromInteger--instance Fractional a => Fractional (Op a b) where- Op f / Op g = Op $ \a -> f a / g a- recip (Op f) = Op $ recip . f- fromRational = Op . const . fromRational--instance Floating a => Floating (Op a b) where- pi = Op $ const pi- exp (Op f) = Op $ exp . f- sqrt (Op f) = Op $ sqrt . f- log (Op f) = Op $ log . f- sin (Op f) = Op $ sin . f- tan (Op f) = Op $ tan . f- cos (Op f) = Op $ cos . f- asin (Op f) = Op $ asin . f- atan (Op f) = Op $ atan . f- acos (Op f) = Op $ acos . f- sinh (Op f) = Op $ sinh . f- tanh (Op f) = Op $ tanh . f- cosh (Op f) = Op $ cosh . f- asinh (Op f) = Op $ asinh . f- atanh (Op f) = Op $ atanh . f- acosh (Op f) = Op $ acosh . f- Op f ** Op g = Op $ \a -> f a ** g a- logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)-#endif
src/Data/Functor/Contravariant/Compose.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-} -- | -- Module : Data.Functor.Contravariant.Compose -- Copyright : (c) Edward Kmett 2010@@ -17,10 +18,6 @@ ) where import Control.Arrow--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible
src/Data/Functor/Contravariant/Divisible.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE Safe #-} +#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -Wno-deprecations #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant.Divisible@@ -34,10 +38,8 @@ import Control.Applicative import Control.Applicative.Backwards import Control.Arrow-import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity-import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict@@ -47,33 +49,27 @@ import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict -import Data.Either import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Contravariant import Data.Functor.Product import Data.Functor.Reverse+import Data.Monoid (Alt(..))+import Data.Proxy import Data.Void -#if MIN_VERSION_base(4,8,0)-import Data.Monoid (Alt(..))-#else-import Data.Monoid (Monoid(..))-#endif+import GHC.Generics -#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)-import Data.Proxy+#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+import Data.Either #endif #ifdef MIN_VERSION_StateVar import Data.StateVar #endif -#if __GLASGOW_HASKELL__ >= 702-#define GHC_GENERICS-import GHC.Generics-#endif- -------------------------------------------------------------------------------- -- * Contravariant Applicative --------------------------------------------------------------------------------@@ -108,14 +104,14 @@ -- parts of a structure. If we postulate the existance of two primitive -- serializers - @string :: Serializer String@ and @int :: Serializer Int@, we -- would like to be able to combine these into a serializer for pairs of--- @String@s and @Int@s. How can we do this? Simply run both serializer and+-- @String@s and @Int@s. How can we do this? Simply run both serializers and -- combine their output! -- -- @ -- data StringAndInt = StringAndInt String Int -- -- stringAndInt :: Serializer StringAndInt--- stringAndInt = Serializer $ \(StringAndInt s i) ->+-- stringAndInt = Serializer $ \\(StringAndInt s i) -> -- let sBytes = runSerializer string s -- iBytes = runSerializer int i -- in sBytes <> iBytes@@ -133,7 +129,7 @@ -- instance Divisible Serializer where -- conquer = Serializer (const mempty) ----- divide toBC bSerializer cSerializer = Serializer $ \a ->+-- divide toBC bSerializer cSerializer = Serializer $ \\a -> -- case toBC a of -- (b, c) -> -- let bBytes = runSerializer bSerializer b@@ -142,10 +138,11 @@ -- -- stringAndInt :: Serializer StringAndInt -- stringAndInt =--- divide (\(StringAndInt s i) -> (s, i)) string int+-- divide (\\(StringAndInt s i) -> (s, i)) string int -- @ -- class Contravariant f => Divisible f where+ --- | If one can handle split `a` into `(b, c)`, as well as handle `b`s and `c`s, then one can handle `a`s divide :: (a -> (b, c)) -> f b -> f c -> f a -- | Conquer acts as an identity for combining @Divisible@ functors.@@ -202,13 +199,10 @@ divide _ (Const a) (Const b) = Const (mappend a b) conquer = Const mempty -#if MIN_VERSION_base(4,8,0) instance Divisible f => Divisible (Alt f) where divide f (Alt l) (Alt r) = Alt $ divide f l r conquer = Alt conquer-#endif -#ifdef GHC_GENERICS instance Divisible U1 where divide _ U1 U1 = U1 conquer = U1@@ -228,16 +222,11 @@ instance (Applicative f, Divisible g) => Divisible (f :.: g) where divide f (Comp1 l) (Comp1 r) = Comp1 (divide f <$> l <*> r) conquer = Comp1 $ pure conquer-#endif instance Divisible f => Divisible (Backwards f) where divide f (Backwards l) (Backwards r) = Backwards $ divide f l r conquer = Backwards conquer -instance Divisible m => Divisible (ErrorT e m) where- divide f (ErrorT l) (ErrorT r) = ErrorT $ divide (funzip . fmap f) l r- conquer = ErrorT conquer- instance Divisible m => Divisible (ExceptT e m) where divide f (ExceptT l) (ExceptT r) = ExceptT $ divide (funzip . fmap f) l r conquer = ExceptT conquer@@ -246,10 +235,6 @@ divide f (IdentityT l) (IdentityT r) = IdentityT $ divide f l r conquer = IdentityT conquer -instance Divisible m => Divisible (ListT m) where- divide f (ListT l) (ListT r) = ListT $ divide (funzip . map f) l r- conquer = ListT conquer- instance Divisible m => Divisible (MaybeT m) where divide f (MaybeT l) (MaybeT r) = MaybeT $ divide (funzip . fmap f) l r conquer = MaybeT conquer@@ -308,11 +293,9 @@ divide f (Reverse l) (Reverse r) = Reverse $ divide f l r conquer = Reverse conquer -#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) instance Divisible Proxy where divide _ Proxy Proxy = Proxy conquer = Proxy-#endif #ifdef MIN_VERSION_StateVar instance Divisible SettableStateVar where@@ -342,7 +325,7 @@ -- functor has the ability to "fan out" input, under the intuition that contravariant -- functors consume input. ----- In the dicussion for @Divisible@, an example was demonstrated with @Serializer@s,+-- In the discussion for @Divisible@, an example was demonstrated with @Serializer@s, -- that turn @a@s into @ByteString@s. @Divisible@ allowed us to serialize the /product/ -- of multiple values by concatenation. By making our @Serializer@ also @Decidable@- -- we now have the ability to serialize the /sum/ of multiple values - for example@@ -360,7 +343,7 @@ -- -- @ -- identifier :: Serializer Identifier--- identifier = Serializer $ \identifier ->+-- identifier = Serializer $ \\identifier -> -- case identifier of -- StringId s -> runSerializer string s -- IntId i -> runSerializer int i@@ -371,8 +354,8 @@ -- -- @ -- instance Decidable Serializer where--- lose f = Serializer $ \a -> absurd (f a)--- choose split l r = Serializer $ \a ->+-- lose f = Serializer $ \\a -> absurd (f a)+-- choose split l r = Serializer $ \\a -> -- either (runSerializer l) (runSerializer r) (split a) -- @ --@@ -415,7 +398,7 @@ Right d -> h c d instance Decidable Equivalence where- lose f = Equivalence $ \a -> absurd (f a)+ lose f = Equivalence $ absurd . f choose f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of Left c -> case f b of Left d -> g c d@@ -425,20 +408,17 @@ Right d -> h c d instance Decidable Predicate where- lose f = Predicate $ \a -> absurd (f a)+ lose f = Predicate $ absurd . f choose f (Predicate g) (Predicate h) = Predicate $ either g h . f instance Monoid r => Decidable (Op r) where lose f = Op $ absurd . f choose f (Op g) (Op h) = Op $ either g h . f -#if MIN_VERSION_base(4,8,0) instance Decidable f => Decidable (Alt f) where lose = Alt . lose choose f (Alt l) (Alt r) = Alt $ choose f l r-#endif -#ifdef GHC_GENERICS instance Decidable U1 where lose _ = U1 choose _ U1 U1 = U1@@ -458,7 +438,6 @@ instance (Applicative f, Decidable g) => Decidable (f :.: g) where lose = Comp1 . pure . lose choose f (Comp1 l) (Comp1 r) = Comp1 (choose f <$> l <*> r)-#endif instance Decidable f => Decidable (Backwards f) where lose = Backwards . lose@@ -488,17 +467,27 @@ (abc a)) (rsmb r s) (rsmc r s) +#if !(MIN_VERSION_transformers(0,6,0))+instance Divisible m => Divisible (ErrorT e m) where+ divide f (ErrorT l) (ErrorT r) = ErrorT $ divide (funzip . fmap f) l r+ conquer = ErrorT conquer++instance Divisible m => Divisible (ListT m) where+ divide f (ListT l) (ListT r) = ListT $ divide (funzip . map f) l r+ conquer = ListT conquer+ instance Divisible m => Decidable (ListT m) where lose _ = ListT conquer choose f (ListT l) (ListT r) = ListT $ divide ((lefts &&& rights) . map f) l r+#endif instance Divisible m => Decidable (MaybeT m) where lose _ = MaybeT conquer choose f (MaybeT l) (MaybeT r) = MaybeT $ divide ( maybe (Nothing, Nothing) (either (\b -> (Just b, Nothing))- (\c -> (Nothing, Just c)))- . fmap f) l r+ (\c -> (Nothing, Just c)) . f)+ ) l r instance Decidable m => Decidable (Lazy.StateT s m) where lose f = Lazy.StateT $ \_ -> contramap lazyFst (lose f)@@ -543,11 +532,9 @@ lazyFst :: (a, b) -> a lazyFst ~(a, _) = a -#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) instance Decidable Proxy where lose _ = Proxy choose _ Proxy Proxy = Proxy-#endif #ifdef MIN_VERSION_StateVar instance Decidable SettableStateVar where@@ -589,7 +576,7 @@ -- 'divide' f m 'conquer' = 'contramap' ('fst' . f) m -- 'divide' f 'conquer' m = 'contramap' ('snd' . f) m -- 'divide' f ('divide' g m n) o = 'divide' f' m ('divide' 'id' n o) where--- f' a = case f a of (bc,d) -> case g bc of (b,c) -> (a,(b,c))+-- f' a = let (bc, d) = f a; (b, c) = g bc in (b, (c, d)) -- @ -- $conquer@@ -611,8 +598,8 @@ -- @ -- 'choose' 'Left' m ('lose' f) = m -- 'choose' 'Right' ('lose' f) m = m--- 'choose' f ('choose' g m n) o = 'divide' f' m ('divide' 'id' n o) where--- f' bcd = 'either' ('either' 'id' ('Right' . 'Left') . g) ('Right' . 'Right') . f+-- 'choose' f ('choose' g m n) o = 'choose' f' m ('choose' 'id' n o) where+-- f' = 'either' ('either' 'id' 'Left' . g) ('Right' . 'Right') . f -- @ -- -- In addition, we expect the same kind of distributive law as is satisfied by the usual
src/Data/Functor/Contravariant/Generic.hs view
@@ -1,9 +1,5 @@ {-# LANGUAGE CPP #-}-#ifdef SAFE-{-# LANGUAGE BangPatterns #-}-#elif __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE Safe #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,9 +7,9 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-}-#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyCase #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant.Generic@@ -36,9 +32,6 @@ import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import GHC.Generics-#ifndef SAFE-import Unsafe.Coerce-#endif -- | This provides machinery for deconstructing an arbitrary 'Generic' instance using a 'Decidable' 'Contravariant' functor. --@@ -53,14 +46,53 @@ -- geq :: 'Deciding' 'Eq' a => a -> a -> 'Bool' -- geq = 'getEquivalence' $ 'deciding' (Proxy :: Proxy 'Eq') ('Equivalence' ('==')) -- @-class (Generic a, GDeciding q (Rep a)) => Deciding q a where+class (Generic a, GDeciding q (Rep' a)) => Deciding q a where #ifndef HLINT deciding :: Decidable f => p q -> (forall b. q b => f b) -> f a #endif -instance (Generic a, GDeciding q (Rep a)) => Deciding q a where- deciding p q = contramap from $ gdeciding p q+instance (Generic a, GG (Rep a), GDeciding q (Rep' a)) => Deciding q a where+ deciding p q = contramap (swizzle . from) $ gdeciding p q +type Rep' a = Swizzle (Rep a)+type Rep1' f = Swizzle (Rep1 f)+type family Swizzle (r :: * -> *) :: * -> *+type instance Swizzle (M1 i c f) = M1 i c (Swizzle f)+type instance Swizzle V1 = V1+type instance Swizzle U1 = U1+type instance Swizzle Par1 = Par1+type instance Swizzle (Rec1 f) = Rec1 f+type instance Swizzle (K1 i c) = K1 i c+type instance Swizzle (f :+: g) = Swizzle f ::+: Swizzle g+type instance Swizzle (f :*: g) = Swizzle f ::*: Swizzle g+type instance Swizzle (f :.: g) = f :.: Swizzle g++newtype (::+:) f g a = Sum {unSum :: Either (f a) (g a)}+newtype (::*:) f g a = Prod {unProd :: (f a, g a)}++class GG r where+ swizzle :: r p -> Swizzle r p+instance GG f => GG (M1 i c f) where+ swizzle (M1 a) = M1 (swizzle a)+instance GG V1 where swizzle v = v+instance GG U1 where swizzle v = v+instance GG (K1 i c) where swizzle v = v+instance GG Par1 where swizzle v = v+instance GG (Rec1 f) where swizzle v = v+instance (GG f, GG g) => GG (f :+: g) where+ {-# INLINE swizzle #-}+ swizzle (L1 x) = Sum (Left (swizzle x))+ swizzle (R1 x) = Sum (Right (swizzle x))+instance (GG f, GG g) => GG (f :*: g) where+ {-# INLINE swizzle #-}+ swizzle (x :*: y) = Prod (swizzle x, swizzle y)+{-+-- This instance wouldn't be that efficient. But we don't+-- offer instances for compositions anyway.+instance (Functor f, GG g) => GG (f :.: g) where+ swizzle (Comp1 x) = Comp1 (fmap swizzle x)+-}+ -- | This provides machinery for deconstructing an arbitrary 'Generic1' instance using a 'Decidable' 'Contravariant' functor. -- -- /Examples:/@@ -74,13 +106,13 @@ -- geq1 :: 'Deciding1' 'Eq' f => (a -> a -> 'Bool') -> f a -> f a -> 'Bool' -- geq1 f = 'getEquivalence' $ 'deciding1' (Proxy :: Proxy 'Eq') ('Equivalence' ('==')) ('Equivalence' f) -- @-class (Generic1 t, GDeciding1 q (Rep1 t)) => Deciding1 q t where+class (Generic1 t, GDeciding1 q (Rep1' t)) => Deciding1 q t where #ifndef HLINT deciding1 :: Decidable f => p q -> (forall b. q b => f b) -> f a -> f (t a) #endif -instance (Generic1 t, GDeciding1 q (Rep1 t)) => Deciding1 q t where- deciding1 p q r = contramap from1 $ gdeciding1 p q r+instance (Generic1 t, GDeciding1 q (Rep1' t), GG (Rep1 t)) => Deciding1 q t where+ deciding1 p q r = contramap (swizzle . from1) $ gdeciding1 p q r class GDeciding q t where #ifndef HLINT@@ -93,10 +125,10 @@ instance GDeciding q V1 where gdeciding _ _ = glose -instance (GDeciding q f, GDeciding q g) => GDeciding q (f :*: g) where+instance (GDeciding q f, GDeciding q g) => GDeciding q (f ::*: g) where gdeciding p q = gdivide (gdeciding p q) (gdeciding p q) -instance (GDeciding q f, GDeciding q g) => GDeciding q (f :+: g) where+instance (GDeciding q f, GDeciding q g) => GDeciding q (f ::+: g) where gdeciding p q = gchoose (gdeciding p q) (gdeciding p q) #ifndef HLINT@@ -118,36 +150,25 @@ instance GDeciding1 q V1 where gdeciding1 _ _ _ = glose -instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f :*: g) where+instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f ::*: g) where gdeciding1 p q r = gdivide (gdeciding1 p q r) (gdeciding1 p q r) -instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f :+: g) where+instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f ::+: g) where gdeciding1 p q r = gchoose (gdeciding1 p q r) (gdeciding1 p q r) -+absurd1 :: V1 a -> b+absurd1 x = case x of glose :: Decidable f => f (V1 a)-#ifdef SAFE-glose = lose (\ !_ -> error "impossible")-#else-glose = lose unsafeCoerce-#endif+glose = lose absurd1 {-# INLINE glose #-} -gdivide :: Divisible f => f (g a) -> f (h a) -> f ((g:*:h) a)-#ifdef SAFE-gdivide = divide (\(f:*:g) -> (f,g))-#else-gdivide = divide unsafeCoerce-#endif+gdivide :: Divisible f => f (g a) -> f (h a) -> f ((g::*:h) a)+gdivide = divide unProd {-# INLINE gdivide #-} -gchoose :: Decidable f => f (g a) -> f (h a) -> f ((g:+:h) a)-#ifdef SAFE-gchoose = choose (\xs -> case xs of L1 a -> Left a; R1 b -> Right b)-#else-gchoose = choose unsafeCoerce-#endif+gchoose :: Decidable f => f (g a) -> f (h a) -> f ((g::+:h) a)+gchoose = choose unSum {-# INLINE gchoose #-} #ifndef HLINT