contravariant-1.5.5/0000755000000000000000000000000007346545000012566 5ustar0000000000000000contravariant-1.5.5/.hlint.yaml0000644000000000000000000000023707346545000014650 0ustar0000000000000000- arguments: [--cpp-define=HLINT, --cpp-define=GHC_GENERICS, --cpp-ansi] - ignore: {name: Eta reduce} - ignore: {name: Use const} - ignore: {name: Use first} contravariant-1.5.5/CHANGELOG.markdown0000644000000000000000000000630507346545000015625 0ustar00000000000000001.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`. * Add lots of documentation explaining `Contravariant`, `Divisible`, and `Decidable`. * Fix some dodgy CPP usage that caused the build to fail on Eta. 1.4 --- * Improved the performance of `Deciding` at the cost of downgrading it to `Trustworthy`. * Support for GHC 8 * Support for `transformers` 0.5 1.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.2 ----- * Renamed `Data.Functor.Contravariant.Applicative` to `Data.Functor.Contravariant.Divisible` 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.5.5/LICENSE0000644000000000000000000000266007346545000013577 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.5.5/README.markdown0000644000000000000000000000104307346545000015265 0ustar0000000000000000contravariant ============= [![Hackage](https://img.shields.io/hackage/v/contravariant.svg)](https://hackage.haskell.org/package/contravariant) [![Build Status](https://github.com/ekmett/contravariant/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/contravariant/actions?query=workflow%3AHaskell-CI) Haskell 98 contravariant functors Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett contravariant-1.5.5/Setup.lhs0000644000000000000000000000016507346545000014400 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain contravariant-1.5.5/contravariant.cabal0000644000000000000000000000574107346545000016434 0ustar0000000000000000name: contravariant category: Control, Data version: 1.5.5 license: BSD3 cabal-version: >= 1.10 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 tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.4 , GHC == 9.0.1 extra-source-files: .hlint.yaml CHANGELOG.markdown README.markdown 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.3 && < 0.7 if !impl(ghc > 7.10) build-depends: transformers-compat >= 0.5 && < 1 if !impl(ghc >= 7.9) build-depends: void >= 0.6.1 && < 1 if flag(tagged) && !impl(ghc >= 7.7) build-depends: tagged >= 0.8.6.1 && < 1 if flag(semigroups) && !impl(ghc >= 7.11) build-depends: semigroups >= 0.18.5 && < 1 if flag(StateVar) build-depends: StateVar >= 1.2.1 && < 1.3 if impl(ghc >= 7.2 && < 7.6) build-depends: ghc-prim exposed-modules: Data.Functor.Contravariant.Compose Data.Functor.Contravariant.Divisible 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 contravariant-1.5.5/old-src/Data/Functor/0000755000000000000000000000000007346545000016422 5ustar0000000000000000contravariant-1.5.5/old-src/Data/Functor/Contravariant.hs0000644000000000000000000003415107346545000021575 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 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if !(MIN_VERSION_transformers(0,6,0)) {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif ----------------------------------------------------------------------------- -- | -- 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.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 #if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Error import Control.Monad.Trans.List #endif #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 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 (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 #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) 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 contravariant-1.5.5/src/Data/Functor/Contravariant/0000755000000000000000000000000007346545000020461 5ustar0000000000000000contravariant-1.5.5/src/Data/Functor/Contravariant/Compose.hs0000644000000000000000000000445407346545000022431 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif -- | -- 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.5.5/src/Data/Functor/Contravariant/Divisible.hs0000644000000000000000000005213007346545000022730 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if !(MIN_VERSION_transformers(0,6,0)) {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif ----------------------------------------------------------------------------- -- | -- 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 -- * Mathematical definitions -- ** Divisible -- $divisible -- *** A note on 'conquer' -- $conquer -- ** Decidable -- $decidable ) where import Control.Applicative import Control.Applicative.Backwards import Control.Arrow 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.Functor.Compose import Data.Functor.Constant import Data.Functor.Contravariant import Data.Functor.Product import Data.Functor.Reverse import Data.Void #if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Error import Control.Monad.Trans.List import Data.Either #endif #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) #else import Data.Monoid (Monoid(..)) #endif #if MIN_VERSION_base(4,7,0) || defined(MIN_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 -------------------------------------------------------------------------------- -- * Contravariant Applicative -------------------------------------------------------------------------------- -- | -- -- A 'Divisible' contravariant functor is the contravariant analogue of 'Applicative'. -- -- Continuing the intuition that 'Contravariant' functors consume input, a 'Divisible' -- contravariant functor also has the ability to be composed "beside" another contravariant -- functor. -- -- Serializers provide a good example of 'Divisible' contravariant functors. To begin -- let's start with the type of serializers for specific types: -- -- @ -- newtype Serializer a = Serializer { runSerializer :: a -> ByteString } -- @ -- -- This is a contravariant functor: -- -- @ -- instance Contravariant Serializer where -- contramap f s = Serializer (runSerializer s . f) -- @ -- -- That is, given a serializer for @a@ (@s :: Serializer a@), and a way to turn -- @b@s into @a@s (a mapping @f :: b -> a@), we have a serializer for @b@: -- @contramap f s :: Serializer b@. -- -- Divisible gives us a way to combine two serializers that focus on different -- 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 serializers and -- combine their output! -- -- @ -- data StringAndInt = StringAndInt String Int -- -- stringAndInt :: Serializer StringAndInt -- stringAndInt = Serializer $ \\(StringAndInt s i) -> -- let sBytes = runSerializer string s -- iBytes = runSerializer int i -- in sBytes <> iBytes -- @ -- -- 'divide' is a generalization by also taking a 'contramap' like function to -- split any @a@ into a pair. This conveniently allows you to target fields of -- a record, for instance, by extracting the values under two fields and -- combining them into a tuple. -- -- To complete the example, here is how to write @stringAndInt@ using a -- @Divisible@ instance: -- -- @ -- instance Divisible Serializer where -- conquer = Serializer (const mempty) -- -- divide toBC bSerializer cSerializer = Serializer $ \\a -> -- case toBC a of -- (b, c) -> -- let bBytes = runSerializer bSerializer b -- cBytes = runSerializer cSerializer c -- in bBytes <> cBytes -- -- stringAndInt :: Serializer StringAndInt -- stringAndInt = -- 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. 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_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 instance Divisible f => Divisible (Rec1 f) where divide f (Rec1 l) (Rec1 r) = Rec1 $ divide f l r conquer = Rec1 conquer instance Divisible f => Divisible (M1 i c f) where divide f (M1 l) (M1 r) = M1 $ divide f l r conquer = M1 conquer instance (Divisible f, Divisible g) => Divisible (f :*: g) where divide f (l1 :*: r1) (l2 :*: r2) = divide f l1 l2 :*: divide f r1 r2 conquer = conquer :*: conquer 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 (ExceptT e m) where divide f (ExceptT l) (ExceptT r) = ExceptT $ divide (funzip . fmap f) l r conquer = ExceptT conquer instance Divisible f => Divisible (IdentityT f) where divide f (IdentityT l) (IdentityT r) = IdentityT $ divide f l r conquer = IdentityT conquer instance Divisible m => Divisible (MaybeT m) where divide f (MaybeT l) (MaybeT r) = MaybeT $ divide (funzip . fmap f) l r conquer = MaybeT conquer instance Divisible m => Divisible (ReaderT r m) where divide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divide abc (rmb r) (rmc r) conquer = ReaderT $ \_ -> conquer instance Divisible m => Divisible (Lazy.RWST r w s m) where divide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> divide (\ ~(a, s', w) -> case abc a of ~(b, c) -> ((b, s', w), (c, s', w))) (rsmb r s) (rsmc r s) conquer = Lazy.RWST $ \_ _ -> conquer instance Divisible m => Divisible (Strict.RWST r w s m) where divide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> divide (\(a, s', w) -> case abc a of (b, c) -> ((b, s', w), (c, s', w))) (rsmb r s) (rsmc r s) conquer = Strict.RWST $ \_ _ -> conquer instance Divisible m => Divisible (Lazy.StateT s m) where divide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> divide (lazyFanout f) (l s) (r s) conquer = Lazy.StateT $ \_ -> conquer instance Divisible m => Divisible (Strict.StateT s m) where divide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> divide (strictFanout f) (l s) (r s) conquer = Strict.StateT $ \_ -> conquer instance Divisible m => Divisible (Lazy.WriterT w m) where divide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ divide (lazyFanout f) l r conquer = Lazy.WriterT conquer instance Divisible m => Divisible (Strict.WriterT w m) where divide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ divide (strictFanout f) l r conquer = Strict.WriterT conquer instance (Applicative f, Divisible g) => Divisible (Compose f g) where divide f (Compose l) (Compose r) = Compose (divide f <$> l <*> r) conquer = Compose $ pure conquer instance Monoid m => Divisible (Constant m) where divide _ (Constant l) (Constant r) = Constant $ mappend l r conquer = Constant mempty instance (Divisible f, Divisible g) => Divisible (Product f g) where divide f (Pair l1 r1) (Pair l2 r2) = Pair (divide f l1 l2) (divide f r1 r2) conquer = Pair conquer conquer instance Divisible f => Divisible (Reverse f) where 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 divide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of (b, c) -> l b >> r c conquer = SettableStateVar $ \_ -> return () #endif lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) lazyFanout f ~(a, s) = case f a of ~(b, c) -> ((b, s), (c, s)) strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s)) strictFanout f (a, s) = case f a of (b, c) -> ((b, s), (c, s)) funzip :: Functor f => f (a, b) -> (f a, f b) funzip = fmap fst &&& fmap snd -------------------------------------------------------------------------------- -- * Contravariant Alternative -------------------------------------------------------------------------------- -- | A 'Decidable' contravariant functor is the contravariant analogue of 'Alternative'. -- -- Noting the superclass constraint that @f@ must also be 'Divisible', a @Decidable@ -- functor has the ability to "fan out" input, under the intuition that contravariant -- functors consume input. -- -- 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 -- different constructors in an ADT. -- -- Consider serializing arbitrary identifiers that can be either @String@s or @Int@s: -- -- @ -- data Identifier = StringId String | IntId Int -- @ -- -- We know we have serializers for @String@s and @Int@s, but how do we combine them -- into a @Serializer@ for @Identifier@? Essentially, our @Serializer@ needs to -- scrutinise the incoming value and choose how to serialize it: -- -- @ -- identifier :: Serializer Identifier -- identifier = Serializer $ \\identifier -> -- case identifier of -- StringId s -> runSerializer string s -- IntId i -> runSerializer int i -- @ -- -- It is exactly this notion of choice that @Decidable@ encodes. Hence if we add -- an instance of @Decidable@ for @Serializer@... -- -- @ -- instance Decidable Serializer where -- lose f = Serializer $ \\a -> absurd (f a) -- choose split l r = Serializer $ \\a -> -- either (runSerializer l) (runSerializer r) (split a) -- @ -- -- Then our @identifier@ @Serializer@ is -- -- @ -- identifier :: Serializer Identifier -- identifier = choose toEither string int where -- toEither (StringId s) = Left s -- toEither (IntId i) = Right i -- @ class Divisible f => Decidable f where -- | Acts as identity to 'choose'. 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 $ 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 Right{} -> False Right c -> case f b of Left{} -> False Right d -> h c d instance Decidable Predicate where 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 instance Decidable f => Decidable (Rec1 f) where lose = Rec1 . lose choose f (Rec1 l) (Rec1 r) = Rec1 $ choose f l r instance Decidable f => Decidable (M1 i c f) where lose = M1 . lose choose f (M1 l) (M1 r) = M1 $ choose f l r instance (Decidable f, Decidable g) => Decidable (f :*: g) where lose f = lose f :*: lose f choose f (l1 :*: r1) (l2 :*: r2) = choose f l1 l2 :*: choose f r1 r2 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 choose f (Backwards l) (Backwards r) = Backwards $ choose f l r instance Decidable f => Decidable (IdentityT f) where lose = IdentityT . lose choose f (IdentityT l) (IdentityT r) = IdentityT $ choose f l r instance Decidable m => Decidable (ReaderT r m) where lose f = ReaderT $ \_ -> lose f choose abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> choose abc (rmb r) (rmc r) instance Decidable m => Decidable (Lazy.RWST r w s m) where lose f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (lose f) choose abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> choose (\ ~(a, s', w) -> either (Left . betuple3 s' w) (Right . betuple3 s' w) (abc a)) (rsmb r s) (rsmc r s) instance Decidable m => Decidable (Strict.RWST r w s m) where lose f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (lose f) choose abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> choose (\(a, s', w) -> either (Left . betuple3 s' w) (Right . betuple3 s' w) (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)) . f) ) l r instance Decidable m => Decidable (Lazy.StateT s m) where lose f = Lazy.StateT $ \_ -> contramap lazyFst (lose f) choose f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> choose (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) (l s) (r s) instance Decidable m => Decidable (Strict.StateT s m) where lose f = Strict.StateT $ \_ -> contramap fst (lose f) choose f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> choose (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) (l s) (r s) instance Decidable m => Decidable (Lazy.WriterT w m) where lose f = Lazy.WriterT $ contramap lazyFst (lose f) choose f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ choose (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r instance Decidable m => Decidable (Strict.WriterT w m) where lose f = Strict.WriterT $ contramap fst (lose f) choose f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ choose (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r instance (Applicative f, Decidable g) => Decidable (Compose f g) where lose = Compose . pure . lose choose f (Compose l) (Compose r) = Compose (choose f <$> l <*> r) instance (Decidable f, Decidable g) => Decidable (Product f g) where lose f = Pair (lose f) (lose f) choose f (Pair l1 r1) (Pair l2 r2) = Pair (choose f l1 l2) (choose f r1 r2) instance Decidable f => Decidable (Reverse f) where lose = Reverse . lose choose f (Reverse l) (Reverse r) = Reverse $ choose f l r betuple :: s -> a -> (a, s) betuple s a = (a, s) betuple3 :: s -> w -> a -> (a, s, w) betuple3 s w a = (a, s, w) 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 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 -- $divisible -- -- 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 = let (bc, d) = f a; (b, c) = g bc in (b, (c, d)) -- @ -- $conquer -- 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. -- $decidable -- -- 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 = '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 -- covariant 'Alternative', w.r.t 'Applicative', which should be fully formulated and -- added here at some point! contravariant-1.5.5/src/Data/Functor/Contravariant/Generic.hs0000644000000000000000000001432707346545000022400 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #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, 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:/ -- -- @ -- 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), 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 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 _ _ = glose 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 gdeciding p q = gchoose (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 _ _ _ = glose 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 gdeciding1 p q r = gchoose (gdeciding1 p q r) (gdeciding1 p q r) absurd1 :: V1 a -> b #if defined(HLINT) || (__GLASGOW_HASKELL__ < 708) absurd1 x = x `seq` error "impossible" #else absurd1 x = case x of #endif glose :: Decidable f => f (V1 a) glose = lose absurd1 {-# INLINE glose #-} 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) gchoose = choose unSum {-# INLINE gchoose #-} #ifndef HLINT instance q p => GDeciding1 q (K1 i p) where gdeciding1 _ q _ = contramap unK1 q #endif 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)