contravariant-1.3.3/0000755000000000000000000000000012572271560012566 5ustar0000000000000000contravariant-1.3.3/.travis.yml0000644000000000000000000000355412572271560014706 0ustar0000000000000000# NB: don't set `language: haskell` here # See also https://github.com/hvr/multi-ghc-travis for more information env: # we have to use CABALVER=1.16 for GHC<7.6 as well, as there's # no package for earlier cabal versions in the PPA - GHCVER=7.4.2 CABALVER=1.16 - GHCVER=7.6.3 CABALVER=1.16 - GHCVER=7.8.4 CABALVER=1.18 - GHCVER=7.10.1 CABALVER=1.22 - GHCVER=head CABALVER=1.22 matrix: allow_failures: - env: GHCVER=head CABALVER=1.22 # Note: the distinction between `before_install` and `install` is not # important. before_install: - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - cabal --version install: - travis_retry cabal update - cabal install --only-dependencies - travis_retry sudo apt-get -q -y install hlint || cabal install hlint # 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: # -v2 provides useful information for debugging - cabal configure -v2 # this builds all libraries and executables # (including tests/benchmarks) - cabal build # tests that a source-distribution can be generated - cabal sdist - hlint src --cpp-define HLINT # check that the generated source-distribution can be built & installed - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install --force-reinstalls "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313contravariant\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" contravariant-1.3.3/CHANGELOG.markdown0000644000000000000000000000376412572271560015633 0ustar00000000000000001.3.3 ----- * Add `instance Monoid m => Divisible (Const m)` 1.3.2 ----- * Add `($<)` operator 1.3.1.1 ------- * Fixed builds on GHC 7.2 1.3.1 ----- * Added `Data.Functor.Contravariant.Generic` on GHC 7.4+ 1.3 --- * We've merged the `foreign-var` and `StateVar` packages. Transferring support to `StateVar`. 1.2.2.1 ------- * Fixed redundant import warnings on GHC 7.10. 1.2.2 ----- * Added `foreign-var` support. 1.2.1 ----- * Added `phantom` to `Data.Functor.Contravariant`. This combinator was formerly called `coerce` in the `lens` package, but GHC 7.8 added a `coerce` method to base with a different meaning. * Added an unsupported `-f-semigroups` build flag that disables support for the `semigroups` package. * Minor documentation improvements. 1.2.0.1 ----- * Fix build on GHC 7.0.4 1.1.1 ----- * Added `Data.Functor.Contravariant.Applicative` 1.0 --- * Removed `Day` convolution. The right adjoint of Day convolution is in `kan-extensions` as the right Kan lift. Moving these there to avoid forcing orphan instances. It also rather dramatically reduces the number of extensions required. * This requires a first digit bump as it breaks several of my own packages. 0.6.1.1 ------- * Fixed issue with needing `KindSignatures` on older GHCs 0.6.1 ----- * Added covariant `Day` convolution. It isn't contravariant, but it is inspired by the contravariant construction. 0.5.1 ----- * `transformers` 0.4 compatibility 0.5 --- * Added `(>$)` * Added instances for `GHC.Generics` 0.4.4 ----- * Fixed compatibility with GHC 7.7 and tightened `Safe` Haskell support. 0.4.1 ----- * Added `Day` convolution under `Data.Functor.Contravariant.Day`. 0.3 --- * Added `Backwards` and `Reverse` instances for `transformers` 0.3 * Added `instance (Functor f, Contravariant g) => Contravariant (Compose f g)`. (This is non-canonical, but is necessary to support other packages.) * Added `Functor` instances to `ComposeFC` and `ComposeCF` for use when modeling phantom type parameters caused mixing `Functor` + `Contravariant`. contravariant-1.3.3/contravariant.cabal0000644000000000000000000000425112572271560016427 0ustar0000000000000000name: contravariant category: Control, Data version: 1.3.3 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/contravariant/ bug-reports: http://github.com/ekmett/contravariant/issues copyright: Copyright (C) 2007-2015 Edward A. Kmett synopsis: Contravariant functors description: Contravariant functors build-type: Simple extra-source-files: .travis.yml CHANGELOG.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 StateVar description: You can disable the use of the `StateVar` package using `-f-StateVar`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True library hs-source-dirs: src build-depends: base < 5, transformers >= 0.2 && < 0.5, transformers-compat >= 0.3 && < 1, void >= 0.6 && < 1 if flag(tagged) && !impl(ghc >= 7.7) build-depends: tagged >= 0.4.4 && < 1 if flag(semigroups) build-depends: semigroups >= 0.15.2 && < 1 if flag(StateVar) build-depends: StateVar >= 1.1 && < 1.2 if impl(ghc >= 7.2 && < 7.6) build-depends: ghc-prim exposed-modules: Data.Functor.Contravariant Data.Functor.Contravariant.Compose Data.Functor.Contravariant.Divisible if impl(ghc >= 7.4) exposed-modules: Data.Functor.Contravariant.Generic ghc-options: -Wall contravariant-1.3.3/HLint.hs0000644000000000000000000000002512572271560014135 0ustar0000000000000000ignore "Eta reduce" contravariant-1.3.3/LICENSE0000644000000000000000000000266012572271560013577 0ustar0000000000000000Copyright 2007-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. contravariant-1.3.3/Setup.lhs0000644000000000000000000000016512572271560014400 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain contravariant-1.3.3/src/0000755000000000000000000000000012572271560013355 5ustar0000000000000000contravariant-1.3.3/src/Data/0000755000000000000000000000000012572271560014226 5ustar0000000000000000contravariant-1.3.3/src/Data/Functor/0000755000000000000000000000000012572271560015646 5ustar0000000000000000contravariant-1.3.3/src/Data/Functor/Contravariant.hs0000644000000000000000000003065412572271560021025 0ustar0000000000000000{-# 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 -- 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 #ifdef MIN_VERSION_semigroups 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) -- | 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 it's 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 -- | 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 #ifdef MIN_VERSION_semigroups 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 #ifdef MIN_VERSION_semigroups 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) #ifdef MIN_VERSION_semigroups 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 contravariant-1.3.3/src/Data/Functor/Contravariant/0000755000000000000000000000000012572271560020461 5ustar0000000000000000contravariant-1.3.3/src/Data/Functor/Contravariant/Compose.hs0000644000000000000000000000426212572271560022426 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Data.Functor.Contravariant.Compose -- Copyright : (c) Edward Kmett 2010 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : portable -- -- Composition of contravariant functors. module Data.Functor.Contravariant.Compose ( Compose(..) , ComposeFC(..) , ComposeCF(..) ) where import Control.Arrow #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible -- | Composition of two contravariant functors newtype Compose f g a = Compose { getCompose :: f (g a) } instance (Contravariant f, Contravariant g) => Functor (Compose f g) where fmap f (Compose x) = Compose (contramap (contramap f) x) -- | Composition of covariant and contravariant functors newtype ComposeFC f g a = ComposeFC { getComposeFC :: f (g a) } instance (Functor f, Contravariant g) => Contravariant (ComposeFC f g) where contramap f (ComposeFC x) = ComposeFC (fmap (contramap f) x) instance (Functor f, Functor g) => Functor (ComposeFC f g) where fmap f (ComposeFC x) = ComposeFC (fmap (fmap f) x) instance (Applicative f, Divisible g) => Divisible (ComposeFC f g) where conquer = ComposeFC $ pure conquer divide abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ divide abc <$> fb <*> fc instance (Applicative f, Decidable g) => Decidable (ComposeFC f g) where lose f = ComposeFC $ pure (lose f) choose abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ choose abc <$> fb <*> fc -- | Composition of contravariant and covariant functors newtype ComposeCF f g a = ComposeCF { getComposeCF :: f (g a) } instance (Contravariant f, Functor g) => Contravariant (ComposeCF f g) where contramap f (ComposeCF x) = ComposeCF (contramap (fmap f) x) instance (Functor f, Functor g) => Functor (ComposeCF f g) where fmap f (ComposeCF x) = ComposeCF (fmap (fmap f) x) instance (Divisible f, Applicative g) => Divisible (ComposeCF f g) where conquer = ComposeCF conquer divide abc (ComposeCF fb) (ComposeCF fc) = ComposeCF $ divide (funzip . fmap abc) fb fc funzip :: Functor f => f (a, b) -> (f a, f b) funzip = fmap fst &&& fmap snd contravariant-1.3.3/src/Data/Functor/Contravariant/Divisible.hs0000644000000000000000000001556512572271560022743 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant.Divisible -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module supplies contravariant analogues to the 'Applicative' and 'Alternative' classes. ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Divisible ( -- * Contravariant Applicative Divisible(..), divided, conquered, liftD -- * Contravariant Alternative , Decidable(..), chosen, lost ) where import Control.Applicative import Data.Functor.Contravariant #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.Void #if MIN_VERSION_StateVar import Data.StateVar #endif -------------------------------------------------------------------------------- -- * Contravariant Applicative -------------------------------------------------------------------------------- -- | -- -- A 'Divisible' contravariant functor is the contravariant analogue of 'Applicative'. -- -- In denser jargon, a 'Divisible' contravariant functor is a monoid object in the category -- of presheaves from Hask to Hask, equipped with Day convolution mapping the Cartesian -- product of the source to the Cartesian product of the target. -- -- By way of contrast, an 'Applicative' functor can be viewed as a monoid object in the -- category of copresheaves from Hask to Hask, equipped with Day convolution mapping the -- Cartesian product of the source to the Cartesian product of the target. -- -- Given the canonical diagonal morphism: -- -- @ -- delta a = (a,a) -- @ -- -- @'divide' 'delta'@ should be associative with 'conquer' as a unit -- -- @ -- 'divide' 'delta' m 'conquer' = m -- 'divide' 'delta' 'conquer' m = m -- 'divide' 'delta' ('divide' 'delta' m n) o = 'divide' 'delta' m ('divide' 'delta' n o) -- @ -- -- With more general arguments you'll need to reassociate and project using the monoidal -- structure of the source category. (Here fst and snd are used in lieu of the more restricted -- lambda and rho, but this construction works with just a monoidal category.) -- -- @ -- '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)) -- @ class Contravariant f => Divisible f where divide :: (a -> (b, c)) -> f b -> f c -> f a -- | The underlying theory would suggest that this should be: -- -- @ -- conquer :: (a -> ()) -> f a -- @ -- -- However, as we are working over a Cartesian category (Hask) and the Cartesian product, such an input -- morphism is uniquely determined to be @'const' 'mempty'@, so we elide it. conquer :: f a -- | -- @ -- 'divided' = 'divide' 'id' -- @ divided :: Divisible f => f a -> f b -> f (a, b) divided = divide id -- | Redundant, but provided for symmetry. -- -- @ -- 'conquered' = 'conquer -- @ conquered :: Divisible f => f () conquered = conquer -- | -- This is the divisible analogue of 'liftA'. It gives a viable default definition for 'contramap' in terms -- of the members of 'Divisible'. -- -- @ -- 'liftD' f = 'divide' ((,) () . f) 'conquer' -- @ liftD :: Divisible f => (a -> b) -> f b -> f a liftD f = divide ((,) () . f) conquer instance Monoid r => Divisible (Op r) where divide f (Op g) (Op h) = Op $ \a -> case f a of (b, c) -> g b `mappend` h c conquer = Op $ const mempty instance Divisible Comparison where divide f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of (a',a'') -> case f b of (b',b'') -> g a' b' `mappend` h a'' b'' conquer = Comparison $ \_ _ -> EQ instance Divisible Equivalence where divide f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of (a',a'') -> case f b of (b',b'') -> g a' b' && h a'' b'' conquer = Equivalence $ \_ _ -> True instance Divisible Predicate where divide f (Predicate g) (Predicate h) = Predicate $ \a -> case f a of (b, c) -> g b && h c conquer = Predicate $ const True instance Monoid m => Divisible (Const m) where divide _ (Const a) (Const b) = Const (mappend a b) conquer = Const mempty #if MIN_VERSION_StateVar instance Divisible SettableStateVar where divide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of (b, c) -> l b >> r c conquer = SettableStateVar $ \_ -> return () #endif -------------------------------------------------------------------------------- -- * Contravariant Alternative -------------------------------------------------------------------------------- -- | -- -- A 'Divisible' contravariant functor is a monoid object in the category of presheaves -- from Hask to Hask, equipped with Day convolution mapping the cartesian product of the -- source to the Cartesian product of the target. -- -- @ -- '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 -- @ -- -- In addition, we expect the same kind of distributive law as is satisfied by the usual -- covariant 'Alternative', w.r.t 'Applicative', which should be fully formulated and -- added here at some point! class Divisible f => Decidable f where -- | The only way to win is not to play. lose :: (a -> Void) -> f a choose :: (a -> Either b c) -> f b -> f c -> f a -- | -- @ -- 'lost' = 'lose' 'id' -- @ lost :: Decidable f => f Void lost = lose id -- | -- @ -- 'chosen' = 'choose' 'id' -- @ chosen :: Decidable f => f b -> f c -> f (Either b c) chosen = choose id instance Decidable Comparison where lose f = Comparison $ \a _ -> absurd (f a) choose f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of Left c -> case f b of Left d -> g c d Right{} -> LT Right c -> case f b of Left{} -> GT Right d -> h c d instance Decidable Equivalence where lose f = Equivalence $ \a -> absurd (f a) choose f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of Left c -> case f b of Left d -> g c d Right{} -> False Right c -> case f b of Left{} -> False Right d -> h c d instance Decidable Predicate where lose f = Predicate $ \a -> absurd (f a) 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_StateVar instance Decidable SettableVar where lose k = SettableStateVar (absurd . k) choose k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of Left b -> l b Right c -> r c #endif contravariant-1.3.3/src/Data/Functor/Contravariant/Generic.hs0000644000000000000000000001057712572271560022403 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant.Generic -- Copyright : (C) 2007-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : ConstraintKinds -- -- -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Generic ( Deciding(..) , Deciding1(..) ) where import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import GHC.Generics -- | This provides machinery for deconstructing an arbitrary 'Generic' instance using a 'Decidable' 'Contravariant' functor. -- -- /Examples:/ -- -- @ -- gcompare :: 'Deciding' 'Ord' a => a -> a -> 'Ordering' -- gcompare = 'getComparison' $ 'deciding' (Proxy :: Proxy 'Ord') ('Comparison' 'compare') -- @ -- -- @ -- 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 #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 -- | This provides machinery for deconstructing an arbitrary 'Generic1' instance using a 'Decidable' 'Contravariant' functor. -- -- /Examples:/ -- -- @ -- gcompare1 :: 'Deciding1' 'Ord' f => (a -> a -> 'Ordering') -> f a -> f a -> 'Ordering' -- gcompare1 f = 'getComparison' $ 'deciding1' (Proxy :: Proxy 'Ord') ('Comparison' compare) ('Comparison' f) -- @ -- -- @ -- 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 #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 class GDeciding q t where #ifndef HLINT gdeciding :: Decidable f => p q -> (forall b. q b => f b) -> f (t a) #endif instance GDeciding q U1 where gdeciding _ _ = conquer instance GDeciding q V1 where gdeciding _ _ = lose (\ !_ -> error "impossible") instance (GDeciding q f, GDeciding q g) => GDeciding q (f :*: g) where gdeciding p q = divide (\(a :*: b) -> (a, b)) (gdeciding p q) (gdeciding p q) instance (GDeciding q f, GDeciding q g) => GDeciding q (f :+: g) where gdeciding p q = choose (\ xs -> case xs of L1 a -> Left a; R1 a -> Right a) (gdeciding p q) (gdeciding p q) #ifndef HLINT instance q p => GDeciding q (K1 i p) where #endif gdeciding _ q = contramap unK1 q instance GDeciding q f => GDeciding q (M1 i c f) where gdeciding p q = contramap unM1 (gdeciding p q) class GDeciding1 q t where #ifndef HLINT gdeciding1 :: Decidable f => p q -> (forall b. q b => f b) -> f a -> f (t a) #endif instance GDeciding1 q U1 where gdeciding1 _ _ _ = conquer instance GDeciding1 q V1 where gdeciding1 _ _ _ = lose (\ !_ -> error "impossible") instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f :*: g) where gdeciding1 p q r = divide (\(a :*: b) -> (a, b)) (gdeciding1 p q r) (gdeciding1 p q r) instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f :+: g) where gdeciding1 p q r = choose (\ xs -> case xs of L1 a -> Left a; R1 a -> Right a) (gdeciding1 p q r) (gdeciding1 p q r) #ifndef HLINT instance q p => GDeciding1 q (K1 i p) where #endif gdeciding1 _ q _ = contramap unK1 q instance GDeciding1 q f => GDeciding1 q (M1 i c f) where gdeciding1 p q r = contramap unM1 (gdeciding1 p q r) instance GDeciding1 q Par1 where gdeciding1 _ _ r = contramap unPar1 r -- instance GDeciding1 q f => GDeciding1 q (Rec1 f) where gdeciding1 p q r = contramap unRec1 (gdeciding1 p q r) instance Deciding1 q f => GDeciding1 q (Rec1 f) where gdeciding1 p q r = contramap unRec1 (deciding1 p q r)