contravariant 0.2.0.2 → 1.5.6

raw patch · 12 files changed

Files

.hlint.yaml +6/−0
.travis.yml +0/−1
CHANGELOG.markdown +127/−0
Data/Functor/Contravariant.hs +0/−118
Data/Functor/Contravariant/Compose.hs +0/−37
LICENSE +1/−1
README.markdown +17/−0
contravariant.cabal +59/−10
old-src/Data/Functor/Contravariant.hs +400/−0
src/Data/Functor/Contravariant/Compose.hs +62/−0
src/Data/Functor/Contravariant/Divisible.hs +607/−0
src/Data/Functor/Contravariant/Generic.hs +188/−0

+ .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,1 +0,0 @@-language: haskell

+ CHANGELOG.markdown view

@@ -0,0 +1,127 @@+1.5.6 [2026.01.10]+------------------+* Drop support for pre-8.0 versions of GHC.+* Support building with MicroHs.++1.5.5 [2021.07.27]+------------------+* Fix the build on old GHCs using `transformers-0.6.*`.++1.5.4 [2021.07.25]+------------------+* Allow building with `transformers-0.6.*`.++1.5.3 [2020.12.30]+------------------+* Explicitly mark modules as `Safe`.++1.5.2 [2019.06.03]+------------------+* Mark `Data.Functor.Contravariant` and `Data.Functor.Contravariant.Generic`+  as unconditionally `Trustworthy`.++1.5.1 [2019.05.02]+------------------+* Remove the use of `unsafeCoerce` in `Data.Functor.Contravariant.Generic`. As+  a result, the `safe` flag has been removed, as it is no longer used.++1.5 [2018.07.01]+----------------+* Support building with GHC 8.6, where `Data.Functor.Contravariant` has been+  moved into `base`.++1.4.1 [2018.01.18]+------------------+* Add `Semigroup` and `Monoid` instances for `Predicate`.+* 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`.

− Data/Functor/Contravariant.hs

@@ -1,118 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Contravariant--- Copyright   :  (C) 2007-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  portable------ 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,--- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'--- the definition of 'Contravariant' for a given ADT is unambiguous.-------------------------------------------------------------------------------module Data.Functor.Contravariant (-  -- * Contravariant Functors-    Contravariant(..)--  -- * Operators-  , (>$<), (>$$<)--  -- * Predicates-  , Predicate(..)--  -- * Comparisons-  , Comparison(..)-  , defaultComparison--  -- * Equivalence Relations-  , Equivalence(..)-  , defaultEquivalence--  -- * Dual arrows-  , Op(..)-  ) where--import Control.Applicative-import Control.Category-import Data.Functor.Product-import Data.Functor.Constant-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--infixl 4 >$<, >$$<--(>$<) :: Contravariant f => (a -> b) -> f b -> f a-(>$<) = contramap-{-# INLINE (>$<) #-}--(>$$<) :: Contravariant f => f b -> (a -> b) -> f a-(>$$<) = flip contramap-{-# INLINE (>$$<) #-}--newtype Predicate a = Predicate { getPredicate :: a -> Bool }---- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to the input of the predicate.-instance Contravariant Predicate where-  contramap f g = Predicate $ getPredicate g . f---- | Defines a total ordering on a type as per 'compare'-newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }---- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to each input to each input to the--- comparison function.-instance Contravariant Comparison where-  contramap f g = Comparison $ \a b -> getComparison g (f a) (f b)---- | Compare using 'compare'-defaultComparison :: Ord a => Comparison a-defaultComparison = Comparison compare---- | Define an equivalence relation-newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }--- | Equivalence relations are 'Contravariant', because you can--- apply the contramapped function to each input to the equivalence--- relation.-instance Contravariant Equivalence where-  contramap f g = Equivalence $ \a b -> getEquivalence g (f a) (f b)---- | Check for equivalence with '=='-defaultEquivalence :: Eq a => Equivalence a-defaultEquivalence = Equivalence (==)---- | Dual function arrows.-newtype Op a b = Op { getOp :: b -> a }--instance Category Op where-  id = Op id-  Op f . Op g = Op (g . f)--instance Contravariant (Op a) where-  contramap f g = Op (getOp g . f)---- | Data.Functor.Product-instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where-  contramap f (Pair a b) = Pair (contramap f a) (contramap f b)---- | Data.Functor.Constant-instance Contravariant (Constant a) where-  contramap _ (Constant a) = Constant a---- | Control.Applicative.Const-instance Contravariant (Const a) where-  contramap _ (Const a) = Const a

− Data/Functor/Contravariant/Compose.hs

@@ -1,37 +0,0 @@--- |--- 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 Data.Functor.Contravariant---- | 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)---- | 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)-

LICENSE view

@@ -1,4 +1,4 @@-Copyright 2007-2011 Edward Kmett+Copyright 2007-2015 Edward Kmett  All rights reserved.

+ README.markdown view

@@ -0,0 +1,17 @@+contravariant+=============++[![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.cabal view

@@ -1,29 +1,78 @@ name:          contravariant category:      Control, Data-version:       0.2.0.2+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> stability:     provisional homepage:      http://github.com/ekmett/contravariant/ bug-reports:   http://github.com/ekmett/contravariant/issues-copyright:     Copyright (C) 2007-2011 Edward A. Kmett-synopsis:      Haskell 98 contravariant functors-description:   Haskell 98 contravariant functors+copyright:     Copyright (C) 2007-2015 Edward A. Kmett+synopsis:      Contravariant functors+description:   Contravariant functors. build-type:    Simple-extra-source-files: .travis.yml+tested-with:   GHC == 8.0.2+             , GHC == 8.2.2+             , 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:+  .hlint.yaml+  CHANGELOG.markdown+  README.markdown  source-repository head   type: git-  location: git://github.com/ekmett/contravariant.git+  location: https://github.com/ekmett/contravariant.git +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.4+    base         >= 4.9 && < 5,+    transformers >= 0.3 && < 0.7++  if flag(StateVar)+    build-depends: StateVar >= 1.2.1 && < 1.3+   exposed-modules:-    Data.Functor.Contravariant     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 >= 8.6)+    ghc-options: -Wno-star-is-type++  if impl(ghc >= 9.0)+    -- these flags may abort compilation with GHC-8.10+    -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+    ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode+   ghc-options: -Wall+  default-language: Haskell2010

+ old-src/Data/Functor/Contravariant.hs view

@@ -0,0 +1,400 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeOperators #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -Wno-deprecations #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Contravariant+-- Copyright   :  (C) 2007-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,+-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'+-- the definition of 'Contravariant' for a given ADT is unambiguous.+----------------------------------------------------------------------------++module Data.Functor.Contravariant (+  -- * Contravariant Functors+    Contravariant(..)+  , phantom++  -- * Operators+  , (>$<), (>$$<), ($<)++  -- * Predicates+  , Predicate(..)++  -- * Comparisons+  , Comparison(..)+  , defaultComparison++  -- * Equivalence Relations+  , Equivalence(..)+  , defaultEquivalence+  , comparisonEquivalence++  -- * Dual arrows+  , Op(..)+  ) where++import Control.Applicative+import Control.Applicative.Backwards++import Control.Category++import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Function (on)++import Data.Functor.Product+import Data.Functor.Sum+import Data.Functor.Constant+import Data.Functor.Compose+import Data.Functor.Reverse++import Data.Monoid (Alt(..))+import Data.Proxy (Proxy(..))+import Data.Semigroup (Semigroup(..))++import GHC.Generics++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++import Prelude hiding ((.),id)++-- | The class of contravariant functors.+--+-- Whereas in Haskell, one can think of a 'Functor' as containing or producing+-- values, a contravariant functor is a functor that can be thought of as+-- /consuming/ values.+--+-- As an example, consider the type of predicate functions  @a -> Bool@. One+-- such predicate might be @negative x = x < 0@, which+-- classifies integers as to whether they are negative. However, given this+-- predicate, we can re-use it in other situations, providing we have a way to+-- map values /to/ integers. For instance, we can use the @negative@ predicate+-- on a person's bank balance to work out if they are currently overdrawn:+--+-- @+-- newtype Predicate a = Predicate { getPredicate :: a -> Bool }+--+-- instance Contravariant Predicate where+--   contramap f (Predicate p) = Predicate (p . f)+--                                          |   `- First, map the input...+--                                          `----- then apply the predicate.+--+-- overdrawn :: Predicate Person+-- overdrawn = contramap personBankBalance negative+-- @+--+-- Any instance should be subject to the following laws:+--+-- > contramap id = id+-- > contramap f . contramap g = contramap (g . f)+--+-- Note, that the second law follows from the free theorem of the type of+-- 'contramap' and the first law, so you need only check that the former+-- condition holds.++class Contravariant f where+  contramap :: (a -> b) -> f b -> f a++  -- | Replace all locations in the output with the same value.+  -- The default definition is @'contramap' . 'const'@, but this may be+  -- overridden with a more efficient version.+  (>$) :: b -> f b -> f a+  (>$) = contramap . const++-- | If 'f' is both 'Functor' and 'Contravariant' then by the time you factor in the laws+-- of each of those classes, it can't actually use its argument in any meaningful capacity.+--+-- This method is surprisingly useful. Where both instances exist and are lawful we have+-- the following laws:+--+-- @+-- 'fmap' f ≡ 'phantom'+-- 'contramap' f ≡ 'phantom'+-- @+phantom :: (Functor f, Contravariant f) => f a -> f b+phantom x = () <$ x $< ()++infixl 4 >$, $<, >$<, >$$<++-- | This is '>$' with its arguments flipped.+($<) :: Contravariant f => f b -> b -> f a+($<) = flip (>$)+{-# INLINE ($<) #-}++-- | This is an infix alias for 'contramap'.+(>$<) :: Contravariant f => (a -> b) -> f b -> f a+(>$<) = contramap+{-# INLINE (>$<) #-}++-- | This is an infix version of 'contramap' with the arguments flipped.+(>$$<) :: Contravariant f => f b -> (a -> b) -> f a+(>$$<) = flip contramap+{-# INLINE (>$$<) #-}++instance Contravariant f => Contravariant (Alt f) where+  contramap f = Alt . contramap f . getAlt++instance Contravariant V1 where+  contramap _ x = x `seq` undefined++instance Contravariant U1 where+  contramap _ _ = U1++instance Contravariant f => Contravariant (Rec1 f) where+  contramap f (Rec1 fp)= Rec1 (contramap f fp)++instance Contravariant f => Contravariant (M1 i c f) where+  contramap f (M1 fp) = M1 (contramap f fp)++instance Contravariant (K1 i c) where+  contramap _ (K1 c) = K1 c++instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where+  contramap f (xs :*: ys) = contramap f xs :*: contramap f ys++instance (Functor f, Contravariant g) => Contravariant (f :.: g) where+  contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)+  {-# INLINE contramap #-}++instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where+  contramap f (L1 xs) = L1 (contramap f xs)+  contramap f (R1 ys) = R1 (contramap f ys)++instance Contravariant m => Contravariant (ExceptT e m) where+  contramap f = ExceptT . contramap (fmap f) . runExceptT++instance Contravariant f => Contravariant (IdentityT f) where+  contramap f = IdentityT . contramap f . runIdentityT++instance Contravariant m => Contravariant (MaybeT m) where+  contramap f = MaybeT . contramap (fmap f) . runMaybeT++instance Contravariant m => Contravariant (Lazy.RWST r w s m) where+  contramap f m = Lazy.RWST $ \r s ->+    contramap (\ ~(a, s', w) -> (f a, s', w)) $ Lazy.runRWST m r s++instance Contravariant m => Contravariant (Strict.RWST r w s m) where+  contramap f m = Strict.RWST $ \r s ->+    contramap (\ (a, s', w) -> (f a, s', w)) $ Strict.runRWST m r s++instance Contravariant m => Contravariant (ReaderT r m) where+  contramap f = ReaderT . fmap (contramap f) . runReaderT++instance Contravariant m => Contravariant (Lazy.StateT s m) where+  contramap f m = Lazy.StateT $ \s ->+    contramap (\ ~(a, s') -> (f a, s')) $ Lazy.runStateT m s++instance Contravariant m => Contravariant (Strict.StateT s m) where+  contramap f m = Strict.StateT $ \s ->+    contramap (\ (a, s') -> (f a, s')) $ Strict.runStateT m s++instance Contravariant m => Contravariant (Lazy.WriterT w m) where+  contramap f = Lazy.mapWriterT $ contramap $ \ ~(a, w) -> (f a, w)++instance Contravariant m => Contravariant (Strict.WriterT w m) where+  contramap f = Strict.mapWriterT $ contramap $ \ (a, w) -> (f a, w)++instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where+  contramap f (InL xs) = InL (contramap f xs)+  contramap f (InR ys) = InR (contramap f ys)++instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where+  contramap f (Pair a b) = Pair (contramap f a) (contramap f b)++instance Contravariant (Constant a) where+  contramap _ (Constant a) = Constant a++instance Contravariant (Const a) where+  contramap _ (Const a) = Const a++instance (Functor f, Contravariant g) => Contravariant (Compose f g) where+  contramap f (Compose fga) = Compose (fmap (contramap f) fga)+  {-# INLINE contramap #-}++instance Contravariant f => Contravariant (Backwards f) where+  contramap f = Backwards . contramap f . forwards+  {-# INLINE contramap #-}++instance Contravariant f => Contravariant (Reverse f) where+  contramap f = Reverse . contramap f . getReverse+  {-# INLINE contramap #-}++#if !(MIN_VERSION_transformers(0,6,0))+instance Contravariant m => Contravariant (ErrorT e m) where+  contramap f = ErrorT . contramap (fmap f) . runErrorT++instance Contravariant m => Contravariant (ListT m) where+  contramap f = ListT . contramap (fmap f) . runListT+#endif++#ifdef MIN_VERSION_StateVar+instance Contravariant SettableStateVar where+  contramap f (SettableStateVar k) = SettableStateVar (k . f)+  {-# INLINE contramap #-}+#endif++instance Contravariant Proxy where+  contramap _ _ = Proxy++newtype Predicate a = Predicate { getPredicate :: a -> Bool }++-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can+-- apply its function argument to the input of the predicate.+instance Contravariant Predicate where+  contramap f g = Predicate $ getPredicate g . f++instance Semigroup (Predicate a) where+  Predicate p <> Predicate q = Predicate $ \a -> p a && q a++instance Monoid (Predicate a) where+  mempty = Predicate $ const True+  mappend = (<>)++-- | Defines a total ordering on a type as per 'compare'.+--+-- This condition is not checked by the types. You must ensure that the supplied+-- values are valid total orderings yourself.+newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }++-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can+-- apply its function argument to each input of the comparison function.+instance Contravariant Comparison where+  contramap f g = Comparison $ on (getComparison g) f++instance Semigroup (Comparison a) where+  Comparison p <> Comparison q = Comparison $ mappend p q++instance Monoid (Comparison a) where+  mempty = Comparison (\_ _ -> EQ)+  mappend (Comparison p) (Comparison q) = Comparison $ mappend p q++-- | Compare using 'compare'.+defaultComparison :: Ord a => Comparison a+defaultComparison = Comparison compare++-- | This data type represents an equivalence relation.+--+-- Equivalence relations are expected to satisfy three laws:+--+-- __Reflexivity__:+--+-- @+-- 'getEquivalence' f a a = True+-- @+--+-- __Symmetry__:+--+-- @+-- 'getEquivalence' f a b = 'getEquivalence' f b a+-- @+--+-- __Transitivity__:+--+-- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' then so is @'getEquivalence' f a c@+--+-- The types alone do not enforce these laws, so you'll have to check them yourself.+newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }++-- | Equivalence relations are 'Contravariant', because you can+-- apply the contramapped function to each input to the equivalence+-- relation.+instance Contravariant Equivalence where+  contramap f g = Equivalence $ on (getEquivalence g) f++instance Semigroup (Equivalence a) where+  Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b++instance Monoid (Equivalence a) where+  mempty = Equivalence (\_ _ -> True)+  mappend (Equivalence p) (Equivalence q) = Equivalence $ \a b -> p a b && q a b++-- | Check for equivalence with '=='.+--+-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.+defaultEquivalence :: Eq a => Equivalence a+defaultEquivalence = Equivalence (==)++comparisonEquivalence :: Comparison a -> Equivalence a+comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ++-- | Dual function arrows.+newtype Op a b = Op { getOp :: b -> a }++instance Category Op where+  id = Op id+  Op f . Op g = Op (g . f)++instance Contravariant (Op a) where+  contramap f g = Op (getOp g . f)++instance Semigroup a => Semigroup (Op a b) where+  Op p <> Op q = Op $ \a -> p a <> q a++instance Monoid a => Monoid (Op a b) where+  mempty = Op (const mempty)+  mappend (Op p) (Op q) = Op $ \a -> mappend (p a) (q a)++instance Num a => Num (Op a b) where+  Op f + Op g = Op $ \a -> f a + g a+  Op f * Op g = Op $ \a -> f a * g a+  Op f - Op g = Op $ \a -> f a - g a+  abs (Op f) = Op $ abs . f+  signum (Op f) = Op $ signum . f+  fromInteger = Op . const . fromInteger++instance Fractional a => Fractional (Op a b) where+  Op f / Op g = Op $ \a -> f a / g a+  recip (Op f) = Op $ recip . f+  fromRational = Op . const . fromRational++instance Floating a => Floating (Op a b) where+  pi = Op $ const pi+  exp (Op f) = Op $ exp . f+  sqrt (Op f) = Op $ sqrt . f+  log (Op f) = Op $ log . f+  sin (Op f) = Op $ sin . f+  tan (Op f) = Op $ tan . f+  cos (Op f) = Op $ cos . f+  asin (Op f) = Op $ asin . f+  atan (Op f) = Op $ atan . f+  acos (Op f) = Op $ acos . f+  sinh (Op f) = Op $ sinh . f+  tanh (Op f) = Op $ tanh . f+  cosh (Op f) = Op $ cosh . f+  asinh (Op f) = Op $ asinh . f+  atanh (Op f) = Op $ atanh . f+  acosh (Op f) = Op $ acosh . f+  Op f ** Op g = Op $ \a -> f a ** g a+  logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)

+ src/Data/Functor/Contravariant/Compose.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+-- |+-- 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++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

+ src/Data/Functor/Contravariant/Divisible.hs view

@@ -0,0 +1,607 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Safe #-}++#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -Wno-deprecations #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Contravariant.Divisible+-- Copyright   :  (C) 2014-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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.Monoid (Alt(..))+import Data.Proxy+import Data.Void++import GHC.Generics++#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++--------------------------------------------------------------------------------+-- * 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++instance Divisible f => Divisible (Alt f) where+  divide f (Alt l) (Alt r) = Alt $ divide f l r+  conquer = Alt conquer++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++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++instance Divisible Proxy where+  divide _ Proxy Proxy = Proxy+  conquer = Proxy++#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++instance Decidable f => Decidable (Alt f) where+  lose = Alt . lose+  choose f (Alt l) (Alt r) = Alt $ choose f l r++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)++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++instance Decidable Proxy where+  lose _ = Proxy+  choose _ Proxy Proxy = Proxy++#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!

+ src/Data/Functor/Contravariant/Generic.hs view

@@ -0,0 +1,188 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Contravariant.Generic+-- Copyright   :  (C) 2007-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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+absurd1 x = case x of++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)