contravariant 1.5 → 1.5.6
raw patch · 10 files changed
Files
- .hlint.yaml +6/−0
- .travis.yml +0/−167
- CHANGELOG.markdown +27/−0
- HLint.hs +0/−3
- README.markdown +1/−1
- contravariant.cabal +33/−58
- old-src/Data/Functor/Contravariant.hs +16/−74
- src/Data/Functor/Contravariant/Compose.hs +1/−4
- src/Data/Functor/Contravariant/Divisible.hs +29/−42
- 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,167 +0,0 @@-# This Travis job script has been generated by a script via-#-# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' '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-8.6.1"- env: GHCHEAD=true- addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}- - compiler: "ghc-8.4.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}- - compiler: "ghc-8.2.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}- - compiler: "ghc-8.0.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}- - compiler: "ghc-7.10.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}- - compiler: "ghc-7.8.4"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}}- - compiler: "ghc-7.6.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}}- - compiler: "ghc-7.4.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}}- - compiler: "ghc-7.2.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.2.2], sources: [hvr-ghc]}}- - compiler: "ghc-7.0.4"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.0.4], 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-head"- - compiler: "ghc-7.0.4"- - compiler: "ghc-7.2.2"- - compiler: "ghc-8.6.1"--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}- - UNCONSTRAINED=${UNCONSTRAINED-true}- - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}- - 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 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config- for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done-- 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-- grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'-- cabal new-update head.hackage -v- fi- - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'- - "printf 'packages: \".\"\\n' > cabal.project"- - touch cabal.project.local- - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"- - cat cabal.project || true- - cat cabal.project.local || true- - 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"- - touch cabal.project.local- - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"- - cat cabal.project || true- - cat cabal.project.local || true-- # 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","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"]-# EOF
CHANGELOG.markdown view
@@ -1,3 +1,30 @@+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
− 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.5+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,46 +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.3- , GHC == 8.6.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:@@ -65,39 +47,32 @@ library hs-source-dirs: src build-depends:- base < 5,- transformers >= 0.2 && < 0.6-- if !impl(ghc > 7.10)- build-depends: 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 && < 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.Compose Data.Functor.Contravariant.Divisible + 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 >= 7.4)- exposed-modules: Data.Functor.Contravariant.Generic+ 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
@@ -1,29 +1,15 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-} {-# 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+#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -Wno-deprecations #-} #endif -{-# OPTIONS_GHC -fno-warn-deprecations #-}- ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant@@ -68,10 +54,8 @@ 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@@ -89,33 +73,21 @@ 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.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..))-#endif -#ifdef LANGUAGE_DeriveDataTypeable-import Data.Typeable-#endif+import GHC.Generics -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 && defined(VERSION_tagged)-import Data.Proxy+#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 -#if __GLASGOW_HASKELL__ >= 702-#define GHC_GENERICS-import GHC.Generics-#endif- import Prelude hiding ((.),id) -- | The class of contravariant functors.@@ -191,12 +163,9 @@ (>$$<) = 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 @@ -222,20 +191,13 @@ 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 @@ -289,58 +251,50 @@ 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 -#if (__GLASGOW_HASKELL__ >= 707) || defined(VERSION_tagged) instance Contravariant Proxy where contramap _ _ = 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)@@ -372,9 +326,6 @@ -- -- 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@@ -382,10 +333,8 @@ 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)@@ -402,9 +351,6 @@ -- | Dual function arrows. newtype Op a b = Op { getOp :: b -> a }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif instance Category Op where id = Op id@@ -413,16 +359,13 @@ 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@@ -455,4 +398,3 @@ 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,7 +104,7 @@ -- 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! -- -- @@@ -146,6 +142,7 @@ -- @ -- 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@@ -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
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