contravariant 0.6.1.1 → 1.5.6
raw patch · 14 files changed
Files
- .hlint.yaml +6/−0
- .travis.yml +0/−1
- CHANGELOG.markdown +97/−0
- Data/Functor/Contravariant.hs +0/−221
- Data/Functor/Contravariant/Compose.hs +0/−42
- Data/Functor/Contravariant/Day.hs +0/−194
- Data/Functor/Day.hs +0/−169
- LICENSE +1/−1
- README.markdown +17/−0
- contravariant.cabal +48/−20
- 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
@@ -1,3 +1,100 @@+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
− Data/Functor/Contravariant.hs
@@ -1,221 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}--#ifdef __GLASGOW_HASKELL__-#define LANGUAGE_DeriveDataTypeable-{-# LANGUAGE DeriveDataTypeable #-}-#endif--#ifndef MIN_VERSION_tagged-#define MIN_VERSION_tagged(x,y,z) 1-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 && MIN_VERSION_transformers(0,3,0) && MIN_VERSION_tagged(0,6,1)-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module : Data.Functor.Contravariant--- Copyright : (C) 2007-2014 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.Applicative.Backwards--import Control.Category--import Data.Functor.Product-import Data.Functor.Sum-import Data.Functor.Constant-import Data.Functor.Compose-import Data.Functor.Reverse--#ifdef LANGUAGE_DeriveDataTypeable-import Data.Typeable-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 && defined(VERSION_tagged)-import Data.Proxy-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-#define GHC_GENERICS-import GHC.Generics-#endif--import Prelude hiding ((.),id)---- | Any instance should be subject to the following laws:------ > contramap id = id--- > contramap f . contramap g = contramap (g . f)------ Note, that the second law follows from the free theorem of the type of--- 'contramap' and the first law, so you need only check that the former--- condition holds.--class Contravariant f where- contramap :: (a -> b) -> f b -> f a-- -- | Replace all locations in the output with the same value.- -- The default definition is @'contramap' . 'const'@, but this may be- -- overridden with a more efficient version.- (>$) :: b -> f b -> f a- (>$) = contramap . const--infixl 4 >$, >$<, >$$<--(>$<) :: Contravariant f => (a -> b) -> f b -> f a-(>$<) = contramap-{-# INLINE (>$<) #-}--(>$$<) :: Contravariant f => f b -> (a -> b) -> f a-(>$$<) = flip contramap-{-# INLINE (>$$<) #-}--#ifdef GHC_GENERICS-instance Contravariant V1 where- contramap _ x = x `seq` undefined--instance Contravariant U1 where- contramap _ U1 = U1--instance Contravariant f => Contravariant (Rec1 f) where- contramap f (Rec1 fp)= Rec1 (contramap f fp)--instance Contravariant f => Contravariant (M1 i c f) where- contramap f (M1 fp) = M1 (contramap f fp)--instance Contravariant (K1 i c) where- contramap _ (K1 c) = K1 c--instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where- contramap f (xs :*: ys) = contramap f xs :*: contramap f ys--instance (Functor f, Contravariant g) => Contravariant (f :.: g) where- contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)- {-# INLINE contramap #-}--instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where- contramap f (L1 xs) = L1 (contramap f xs)- contramap f (R1 ys) = R1 (contramap f ys)-#endif--instance (Contravariant 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 (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707) || defined(VERSION_tagged)-instance Contravariant Proxy where- contramap _ Proxy = Proxy-#endif--newtype Predicate a = Predicate { getPredicate :: a -> Bool }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif---- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to the input of the predicate.-instance Contravariant Predicate where- contramap f g = Predicate $ getPredicate g . f---- | Defines a total ordering on a type as per 'compare'-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 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 }-#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 $ \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 }-#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)
− Data/Functor/Contravariant/Compose.hs
@@ -1,42 +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)--instance (Functor f, Functor g) => Functor (ComposeFC f g) where- fmap f (ComposeFC x) = ComposeFC (fmap (fmap 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)--instance (Functor f, Functor g) => Functor (ComposeCF f g) where- fmap f (ComposeCF x) = ComposeCF (fmap (fmap f) x)
− Data/Functor/Contravariant/Day.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-#endif-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 707-{-# LANGUAGE KindSignatures #-}-#endif-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Copyright : (C) 2013-2014 Edward Kmett, Gershom Bazerman and Derek Elkins--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ The Day convolution of two contravariant functors is a contravariant--- functor.------ <http://ncatlab.org/nlab/show/Day+convolution>-------------------------------------------------------------------------------module Data.Functor.Contravariant.Day- ( Day(..)- , day- , runDay- , assoc, disassoc- , swapped- , intro1, intro2- , day1, day2- , diag- , trans1, trans2- ) where--import Control.Applicative-import Data.Functor.Contravariant-import Data.Proxy-import Data.Tuple (swap)-#ifdef __GLASGOW_HASKELL__-import Data.Typeable-#endif---- | The Day convolution of two contravariant functors.-data Day f g a = forall b c. Day (f b) (g c) (a -> (b, c))-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif---- | Construct the Day convolution------ @--- 'day1' ('day' f g) = f--- 'day2' ('day' f g) = g--- @-day :: f a -> g b -> Day f g (a, b)-day fa gb = Day fa gb id--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707-instance (Typeable1 f, Typeable1 g) => Typeable1 (Day f g) where- typeOf1 tfga = mkTyConApp dayTyCon [typeOf1 (fa tfga), typeOf1 (ga tfga)]- where fa :: t f (g :: * -> *) a -> f a- fa = undefined- ga :: t (f :: * -> *) g a -> g a- ga = undefined--dayTyCon :: TyCon-#if MIN_VERSION_base(4,4,0)-dayTyCon = mkTyCon3 "contravariant" "Data.Functor.Contravariant.Day" "Day"-#else-dayTyCon = mkTyCon "Data.Functor.Contravariant.Day.Day"-#endif--#endif--instance Contravariant (Day f g) where- contramap f (Day fb gc abc) = Day fb gc (abc . f)---- | Break apart the Day convolution of two contravariant functors.-runDay :: (Contravariant f, Contravariant g) => Day f g a -> (f a, g a)-runDay (Day fb gc abc) =- ( contramap (fst . abc) fb- , contramap (snd . abc) gc- )---- | Day convolution provides a monoidal product. The associativity--- of this monoid is witnessed by 'assoc' and 'disassoc'.------ @--- 'assoc' . 'disassoc' = 'id'--- 'disassoc' . 'assoc' = 'id'--- 'contramap' f '.' 'assoc' = 'assoc' '.' 'contramap' f--- @-assoc :: Day f (Day g h) a -> Day (Day f g) h a-assoc (Day fb (Day gd he cde) abc) = Day (Day fb gd id) he $ \a ->- case cde <$> abc a of- (b, (d, e)) -> ((b, d), e)---- | Day convolution provides a monoidal product. The associativity--- of this monoid is witnessed by 'assoc' and 'disassoc'.------ @--- 'assoc' . 'disassoc' = 'id'--- 'disassoc' . 'assoc' = 'id'--- 'contramap' f '.' 'disassoc' = 'disassoc' '.' 'contramap' f--- @-disassoc :: Day (Day f g) h a -> Day f (Day g h) a-disassoc (Day (Day fd ge bde) hc abc) = Day fd (Day ge hc id) $ \a ->- case abc a of- (b, c) -> case bde b of- (d, e) -> (d, (e, c))---- | The monoid for Day convolution /in Haskell/ is symmetric.------ @--- 'contramap' f '.' 'swapped' = 'swapped' '.' 'contramap' f--- @-swapped :: Day f g a -> Day g f a-swapped (Day fb gc abc) = Day gc fb (swap . abc)---- | Proxy serves as the unit of Day convolution.------ @--- 'day1' '.' 'intro1' = 'id'--- 'contramap' f '.' 'intro1' = 'intro1' '.' 'contramap' f--- @-intro1 :: f a -> Day Proxy f a-intro1 fa = Day Proxy fa $ \a -> ((),a)---- | Proxy serves as the unit of Day convolution.------ @--- 'day2' '.' 'intro2' = 'id'--- 'contramap' f '.' 'intro2' = 'intro2' '.' 'contramap' f--- @-intro2 :: f a -> Day f Proxy a-intro2 fa = Day fa Proxy $ \a -> (a,())---- | In Haskell we can do general purpose elimination, but in a more general setting--- it is only possible to eliminate the unit.------ @--- 'day1' '.' 'intro1' = 'id'--- 'day1' = 'fst' '.' 'runDay'--- 'contramap' f '.' 'day1' = 'day1' '.' 'contramap' f--- @-day1 :: Contravariant f => Day f g a -> f a-day1 (Day fb _ abc) = contramap (fst . abc) fb---- | In Haskell we can do general purpose elimination, but in a more general setting--- it is only possible to eliminate the unit.--- @--- 'day2' '.' 'intro2' = 'id'--- 'day2' = 'snd' '.' 'runDay'--- 'contramap' f '.' 'day2' = 'day2' '.' 'contramap' f--- @-day2 :: Contravariant g => Day f g a -> g a-day2 (Day _ gc abc) = contramap (snd . abc) gc---- | Diagonalize the Day convolution:------ @--- 'day1' '.' 'diag' = 'id'--- 'day2' '.' 'diag' = 'id'--- 'runDay' '.' 'diag' = \a -> (a,a)--- 'contramap' f . 'diag' = 'diag' . 'contramap' f--- @--diag :: f a -> Day f f a-diag fa = Day fa fa $ \a -> (a,a)---- | Apply a natural transformation to the left-hand side of a Day convolution.------ This respects the naturality of the natural transformation you supplied:------ @--- 'contramap' f '.' 'trans1' fg = 'trans1' fg '.' 'contramap' f--- @-trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a-trans1 fg (Day fb hc abc) = Day (fg fb) hc abc---- | Apply a natural transformation to the right-hand side of a Day convolution.------ This respects the naturality of the natural transformation you supplied:------ @--- 'contramap' f '.' 'trans2' fg = 'trans2' fg '.' 'contramap' f--- @-trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a-trans2 gh (Day fb gc abc) = Day fb (gh gc) abc
− Data/Functor/Day.hs
@@ -1,169 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}--------------------------------------------------------------------------------- |--- Copyright : (C) 2014 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ Eitan Chatav first introduced me to this construction------ The Day convolution of two covariant functors is a covariant functor.------ Day convolution is usually defined in terms of contravariant functors,--- however, it just needs a monoidal category, and Hask^op is also monoidal.------ Day convolution can be used to nicely describe monoidal functors as monoid--- objects w.r.t this product.------ <http://ncatlab.org/nlab/show/Day+convolution>-------------------------------------------------------------------------------module Data.Functor.Day- ( Day(..)- , day- , dap- , assoc, disassoc- , swapped- , intro1, intro2- , elim1, elim2- , trans1, trans2- ) where--import Control.Applicative-import Data.Functor.Identity-#ifdef __GLASGOW_HASKELL__-import Data.Typeable-#endif---- | The Day convolution of two covariant functors.-data Day f g a = forall b c. Day (f b) (g c) (b -> c -> a)-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707- deriving Typeable-#endif---- | Construct the Day convolution-day :: f (a -> b) -> g a -> Day f g b-day fa gb = Day fa gb id--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707-instance (Typeable1 f, Typeable1 g) => Typeable1 (Day f g) where- typeOf1 tfga = mkTyConApp dayTyCon [typeOf1 (fa tfga), typeOf1 (ga tfga)]- where fa :: t f (g :: * -> *) a -> f a- fa = undefined- ga :: t (f :: * -> *) g a -> g a- ga = undefined--dayTyCon :: TyCon-#if MIN_VERSION_base(4,4,0)-dayTyCon = mkTyCon3 "contravariant" "Data.Functor.Day" "Day"-#else-dayTyCon = mkTyCon "Data.Functor.Day.Day"-#endif--#endif--instance Functor (Day f g) where- fmap f (Day fb gc bca) = Day fb gc $ \b c -> f (bca b c)---- | Day convolution provides a monoidal product. The associativity--- of this monoid is witnessed by 'assoc' and 'disassoc'.------ @--- 'assoc' . 'disassoc' = 'id'--- 'disassoc' . 'assoc' = 'id'--- 'fmap' f '.' 'assoc' = 'assoc' '.' 'fmap' f--- @-assoc :: Day f (Day g h) a -> Day (Day f g) h a-assoc (Day fb (Day gd he dec) bca) = Day (Day fb gd (,)) he $- \ (b,d) e -> bca b (dec d e)---- | Day convolution provides a monoidal product. The associativity--- of this monoid is witnessed by 'assoc' and 'disassoc'.------ @--- 'assoc' . 'disassoc' = 'id'--- 'disassoc' . 'assoc' = 'id'--- 'fmap' f '.' 'disassoc' = 'disassoc' '.' 'fmap' f--- @-disassoc :: Day (Day f g) h a -> Day f (Day g h) a-disassoc (Day (Day fb gc bce) hd eda) = Day fb (Day gc hd (,)) $ \ b (c,d) ->- eda (bce b c) d---- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric.------ @--- 'fmap' f '.' 'swapped' = 'swapped' '.' 'fmap' f--- @-swapped :: Day f g a -> Day g f a-swapped (Day fb gc abc) = Day gc fb (flip abc)---- | 'Identity' is the unit of 'Day' convolution------ @--- 'intro1' '.' 'elim1' = 'id'--- 'elim1' '.' 'intro1' = 'id'--- @-intro1 :: f a -> Day Identity f a-intro1 fa = Day (Identity ()) fa $ \_ a -> a---- | 'Identity' is the unit of 'Day' convolution------ @--- 'intro2' '.' 'elim2' = 'id'--- 'elim2' '.' 'intro2' = 'id'--- @-intro2 :: f a -> Day f Identity a-intro2 fa = Day fa (Identity ()) const---- | 'Identity' is the unit of 'Day' convolution------ @--- 'intro1' '.' 'elim1' = 'id'--- 'elim1' '.' 'intro1' = 'id'--- @-elim1 :: Functor f => Day Identity f a -> f a-elim1 (Day (Identity b) fc bca) = bca b <$> fc---- | 'Identity' is the unit of 'Day' convolution------ @--- 'intro2' '.' 'elim2' = 'id'--- 'elim2' '.' 'intro2' = 'id'--- @-elim2 :: Functor f => Day f Identity a -> f a-elim2 (Day fb (Identity c) bca) = flip bca c <$> fb---- | Collapse via a monoidal functor.------ @ --- 'dap' ('day' f g) = f '<*>' g--- @-dap :: Applicative f => Day f f a -> f a-dap (Day fb fc abc) = liftA2 abc fb fc---- | Apply a natural transformation to the left-hand side of a Day convolution.------ This respects the naturality of the natural transformation you supplied:------ @--- 'fmap' f '.' 'trans1' fg = 'trans1' fg '.' 'fmap' f--- @-trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a-trans1 fg (Day fb hc bca) = Day (fg fb) hc bca---- | Apply a natural transformation to the right-hand side of a Day convolution.------ This respects the naturality of the natural transformation you supplied:------ @--- 'fmap' f '.' 'trans2' fg = 'trans2' fg '.' 'fmap' f--- @-trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a-trans2 gh (Day fb gc bca) = Day fb (gh gc) bca
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2007-2014 Edward Kmett+Copyright 2007-2015 Edward Kmett All rights reserved.
+ README.markdown view
@@ -0,0 +1,17 @@+contravariant+=============++[](https://hackage.haskell.org/package/contravariant)+[](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,50 +1,78 @@ name: contravariant category: Control, Data-version: 0.6.1.1+version: 1.5.6 license: BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> stability: provisional homepage: http://github.com/ekmett/contravariant/ bug-reports: http://github.com/ekmett/contravariant/issues-copyright: Copyright (C) 2007-2014 Edward A. Kmett-synopsis: Contravariant functors and Day convolution-description: Contravariant functors and Day convolution+copyright: Copyright (C) 2007-2015 Edward A. Kmett+synopsis: Contravariant functors+description: Contravariant functors. build-type: Simple+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:- .travis.yml+ .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 tagged+flag StateVar description:- You can disable the use of the `tagged` package on older versons of GHC using `-f-tagged`.+ You can disable the use of the `StateVar` package using `-f-StateVar`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True library+ hs-source-dirs: src build-depends:- base < 5,- transformers >= 0.2 && < 0.5,- transformers-compat >= 0.3 && < 1-- if flag(tagged) && !impl(ghc >= 7.7)- build-depends: tagged >= 0.4.4 && < 1+ base >= 4.9 && < 5,+ transformers >= 0.3 && < 0.7 - if impl(ghc >= 7.4 && < 7.6)- build-depends: ghc-prim+ if flag(StateVar)+ build-depends: StateVar >= 1.2.1 && < 1.3 exposed-modules:- Data.Functor.Contravariant Data.Functor.Contravariant.Compose- Data.Functor.Contravariant.Day- Data.Functor.Day+ 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)