contravariant-1.4/0000755000000000000000000000000012646536156012435 5ustar0000000000000000contravariant-1.4/.travis.yml0000644000000000000000000000355412646536156014555 0ustar0000000000000000# NB: don't set `language: haskell` here # See also https://github.com/hvr/multi-ghc-travis for more information env: # we have to use CABALVER=1.16 for GHC<7.6 as well, as there's # no package for earlier cabal versions in the PPA - GHCVER=7.4.2 CABALVER=1.16 - GHCVER=7.6.3 CABALVER=1.16 - GHCVER=7.8.4 CABALVER=1.18 - GHCVER=7.10.1 CABALVER=1.22 - GHCVER=head CABALVER=1.22 matrix: allow_failures: - env: GHCVER=head CABALVER=1.22 # Note: the distinction between `before_install` and `install` is not # important. before_install: - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - cabal --version install: - travis_retry cabal update - cabal install --only-dependencies - travis_retry sudo apt-get -q -y install hlint || cabal install hlint # Here starts the actual work to be performed for the package under # test; any command which exits with a non-zero exit code causes the # build to fail. script: # -v2 provides useful information for debugging - cabal configure -v2 # this builds all libraries and executables # (including tests/benchmarks) - cabal build # tests that a source-distribution can be generated - cabal sdist - hlint src --cpp-define HLINT # check that the generated source-distribution can be built & installed - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install --force-reinstalls "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313contravariant\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" contravariant-1.4/CHANGELOG.markdown0000644000000000000000000000421312646536156015470 0ustar00000000000000001.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.1.1 ----- * Added `Data.Functor.Contravariant.Applicative` 1.0 --- * Removed `Day` convolution. The right adjoint of Day convolution is in `kan-extensions` as the right Kan lift. Moving these there to avoid forcing orphan instances. It also rather dramatically reduces the number of extensions required. * This requires a first digit bump as it breaks several of my own packages. 0.6.1.1 ------- * Fixed issue with needing `KindSignatures` on older GHCs 0.6.1 ----- * Added covariant `Day` convolution. It isn't contravariant, but it is inspired by the contravariant construction. 0.5.1 ----- * `transformers` 0.4 compatibility 0.5 --- * Added `(>$)` * Added instances for `GHC.Generics` 0.4.4 ----- * Fixed compatibility with GHC 7.7 and tightened `Safe` Haskell support. 0.4.1 ----- * Added `Day` convolution under `Data.Functor.Contravariant.Day`. 0.3 --- * Added `Backwards` and `Reverse` instances for `transformers` 0.3 * Added `instance (Functor f, Contravariant g) => Contravariant (Compose f g)`. (This is non-canonical, but is necessary to support other packages.) * Added `Functor` instances to `ComposeFC` and `ComposeCF` for use when modeling phantom type parameters caused mixing `Functor` + `Contravariant`. contravariant-1.4/contravariant.cabal0000644000000000000000000000453712646536156016305 0ustar0000000000000000name: contravariant category: Control, Data version: 1.4 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/contravariant/ bug-reports: http://github.com/ekmett/contravariant/issues copyright: Copyright (C) 2007-2015 Edward A. Kmett synopsis: Contravariant functors description: Contravariant functors build-type: Simple extra-source-files: .travis.yml CHANGELOG.markdown HLint.hs source-repository head type: git location: git://github.com/ekmett/contravariant.git flag tagged description: You can disable the use of the `tagged` package using `-f-tagged`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag semigroups description: You can disable the use of the `semigroups` package using `-f-semigroups`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag safe description: Get Safe guarantees rather than merely Trustworthy, but with worse constant factors. default: False manual: True flag StateVar description: You can disable the use of the `StateVar` package using `-f-StateVar`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True library hs-source-dirs: src build-depends: base < 5, transformers >= 0.2 && < 0.6, transformers-compat >= 0.3 && < 1, void >= 0.6 && < 1 if flag(tagged) && !impl(ghc >= 7.7) build-depends: tagged >= 0.4.4 && < 1 if flag(semigroups) build-depends: semigroups >= 0.15.2 && < 1 if flag(StateVar) build-depends: StateVar >= 1.1 && < 1.2 if impl(ghc >= 7.2 && < 7.6) build-depends: ghc-prim if flag(safe) cpp-options: -DSAFE exposed-modules: Data.Functor.Contravariant Data.Functor.Contravariant.Compose Data.Functor.Contravariant.Divisible if impl(ghc >= 7.4) exposed-modules: Data.Functor.Contravariant.Generic ghc-options: -Wall contravariant-1.4/HLint.hs0000644000000000000000000000002512646536156014004 0ustar0000000000000000ignore "Eta reduce" contravariant-1.4/LICENSE0000644000000000000000000000266012646536156013446 0ustar0000000000000000Copyright 2007-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. contravariant-1.4/Setup.lhs0000644000000000000000000000016512646536156014247 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain contravariant-1.4/src/0000755000000000000000000000000012646536156013224 5ustar0000000000000000contravariant-1.4/src/Data/0000755000000000000000000000000012646536156014075 5ustar0000000000000000contravariant-1.4/src/Data/Functor/0000755000000000000000000000000012646536156015515 5ustar0000000000000000contravariant-1.4/src/Data/Functor/Contravariant.hs0000644000000000000000000003065412646536156020674 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} #ifdef __GLASGOW_HASKELL__ #define LANGUAGE_DeriveDataTypeable {-# LANGUAGE DeriveDataTypeable #-} #endif #ifndef MIN_VERSION_tagged #define MIN_VERSION_tagged(x,y,z) 1 #endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #if __GLASGOW_HASKELL__ >= 704 #if MIN_VERSION_transformers(0,3,0) && MIN_VERSION_tagged(0,6,1) {-# LANGUAGE Safe #-} #else {-# LANGUAGE Trustworthy #-} #endif #endif {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant -- Copyright : (C) 2007-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@, -- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor' -- the definition of 'Contravariant' for a given ADT is unambiguous. ---------------------------------------------------------------------------- module Data.Functor.Contravariant ( -- * Contravariant Functors Contravariant(..) , phantom -- * Operators , (>$<), (>$$<), ($<) -- * Predicates , Predicate(..) -- * Comparisons , Comparison(..) , defaultComparison -- * Equivalence Relations , Equivalence(..) , defaultEquivalence , comparisonEquivalence -- * Dual arrows , Op(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Category import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Function (on) import Data.Functor.Product import Data.Functor.Sum import Data.Functor.Constant import Data.Functor.Compose import Data.Functor.Reverse #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) #else import Data.Monoid (Monoid(..)) #endif #ifdef MIN_VERSION_semigroups import Data.Semigroup (Semigroup(..)) #endif #ifdef LANGUAGE_DeriveDataTypeable import Data.Typeable #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 && defined(VERSION_tagged) import Data.Proxy #endif #ifdef MIN_VERSION_StateVar import Data.StateVar #endif #if __GLASGOW_HASKELL__ >= 702 #define GHC_GENERICS import GHC.Generics #endif import Prelude hiding ((.),id) -- | Any instance should be subject to the following laws: -- -- > contramap id = id -- > contramap f . contramap g = contramap (g . f) -- -- Note, that the second law follows from the free theorem of the type of -- 'contramap' and the first law, so you need only check that the former -- condition holds. class Contravariant f where contramap :: (a -> b) -> f b -> f a -- | Replace all locations in the output with the same value. -- The default definition is @'contramap' . 'const'@, but this may be -- overridden with a more efficient version. (>$) :: b -> f b -> f a (>$) = contramap . const -- | If 'f' is both 'Functor' and 'Contravariant' then by the time you factor in the laws -- of each of those classes, it can't actually use it's argument in any meaningful capacity. -- -- This method is surprisingly useful. Where both instances exist and are lawful we have -- the following laws: -- -- @ -- 'fmap' f ≡ 'phantom' -- 'contramap' f ≡ 'phantom' -- @ phantom :: (Functor f, Contravariant f) => f a -> f b phantom x = () <$ x $< () infixl 4 >$, $<, >$<, >$$< -- | This is '>$' with its arguments flipped. ($<) :: Contravariant f => f b -> b -> f a ($<) = flip (>$) {-# INLINE ($<) #-} -- | This is an infix alias for 'contramap' (>$<) :: Contravariant f => (a -> b) -> f b -> f a (>$<) = contramap {-# INLINE (>$<) #-} -- | This is an infix version of 'contramap' with the arguments flipped. (>$$<) :: Contravariant f => f b -> (a -> b) -> f a (>$$<) = flip contramap {-# INLINE (>$$<) #-} #if MIN_VERSION_base(4,8,0) instance Contravariant f => Contravariant (Alt f) where contramap f = Alt . contramap f . getAlt #endif #ifdef GHC_GENERICS instance Contravariant V1 where contramap _ x = x `seq` undefined instance Contravariant U1 where contramap _ U1 = U1 instance Contravariant f => Contravariant (Rec1 f) where contramap f (Rec1 fp)= Rec1 (contramap f fp) instance Contravariant f => Contravariant (M1 i c f) where contramap f (M1 fp) = M1 (contramap f fp) instance Contravariant (K1 i c) where contramap _ (K1 c) = K1 c instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where contramap f (xs :*: ys) = contramap f xs :*: contramap f ys instance (Functor f, Contravariant g) => Contravariant (f :.: g) where contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg) {-# INLINE contramap #-} instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where contramap f (L1 xs) = L1 (contramap f xs) contramap f (R1 ys) = R1 (contramap f ys) #endif instance Contravariant m => Contravariant (ErrorT e m) where contramap f = ErrorT . contramap (fmap f) . runErrorT instance Contravariant m => Contravariant (ExceptT e m) where contramap f = ExceptT . contramap (fmap f) . runExceptT instance Contravariant f => Contravariant (IdentityT f) where contramap f = IdentityT . contramap f . runIdentityT instance Contravariant m => Contravariant (ListT m) where contramap f = ListT . contramap (fmap f) . runListT instance Contravariant m => Contravariant (MaybeT m) where contramap f = MaybeT . contramap (fmap f) . runMaybeT instance Contravariant m => Contravariant (Lazy.RWST r w s m) where contramap f m = Lazy.RWST $ \r s -> contramap (\ ~(a, s', w) -> (f a, s', w)) $ Lazy.runRWST m r s instance Contravariant m => Contravariant (Strict.RWST r w s m) where contramap f m = Strict.RWST $ \r s -> contramap (\ (a, s', w) -> (f a, s', w)) $ Strict.runRWST m r s instance Contravariant m => Contravariant (ReaderT r m) where contramap f = ReaderT . fmap (contramap f) . runReaderT instance Contravariant m => Contravariant (Lazy.StateT s m) where contramap f m = Lazy.StateT $ \s -> contramap (\ ~(a, s') -> (f a, s')) $ Lazy.runStateT m s instance Contravariant m => Contravariant (Strict.StateT s m) where contramap f m = Strict.StateT $ \s -> contramap (\ (a, s') -> (f a, s')) $ Strict.runStateT m s instance Contravariant m => Contravariant (Lazy.WriterT w m) where contramap f = Lazy.mapWriterT $ contramap $ \ ~(a, w) -> (f a, w) instance Contravariant m => Contravariant (Strict.WriterT w m) where contramap f = Strict.mapWriterT $ contramap $ \ (a, w) -> (f a, w) instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where contramap f (InL xs) = InL (contramap f xs) contramap f (InR ys) = InR (contramap f ys) instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where contramap f (Pair a b) = Pair (contramap f a) (contramap f b) instance Contravariant (Constant a) where contramap _ (Constant a) = Constant a instance Contravariant (Const a) where contramap _ (Const a) = Const a instance (Functor f, Contravariant g) => Contravariant (Compose f g) where contramap f (Compose fga) = Compose (fmap (contramap f) fga) {-# INLINE contramap #-} instance Contravariant f => Contravariant (Backwards f) where contramap f = Backwards . contramap f . forwards {-# INLINE contramap #-} instance Contravariant f => Contravariant (Reverse f) where contramap f = Reverse . contramap f . getReverse {-# INLINE contramap #-} #ifdef MIN_VERSION_StateVar instance Contravariant SettableStateVar where contramap f (SettableStateVar k) = SettableStateVar (k . f) {-# INLINE contramap #-} #endif #if (__GLASGOW_HASKELL__ >= 707) || defined(VERSION_tagged) instance Contravariant Proxy where contramap _ Proxy = Proxy #endif newtype Predicate a = Predicate { getPredicate :: a -> Bool } #ifdef LANGUAGE_DeriveDataTypeable deriving Typeable #endif -- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can -- apply its function argument to the input of the predicate. instance Contravariant Predicate where contramap f g = Predicate $ getPredicate g . f -- | Defines a total ordering on a type as per 'compare' -- -- This condition is not checked by the types. You must ensure that the supplied -- values are valid total orderings yourself. newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering } #ifdef LANGUAGE_DeriveDataTypeable deriving Typeable #endif -- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can -- apply its function argument to each input of the comparison function. instance Contravariant Comparison where contramap f g = Comparison $ on (getComparison g) f #ifdef MIN_VERSION_semigroups instance Semigroup (Comparison a) where Comparison p <> Comparison q = Comparison $ mappend p q #endif instance Monoid (Comparison a) where mempty = Comparison (\_ _ -> EQ) mappend (Comparison p) (Comparison q) = Comparison $ mappend p q -- | Compare using 'compare' defaultComparison :: Ord a => Comparison a defaultComparison = Comparison compare -- | This data type represents an equivalence relation. -- -- Equivalence relations are expected to satisfy three laws: -- -- __Reflexivity__: -- -- @ -- 'getEquivalence' f a a = True -- @ -- -- __Symmetry__: -- -- @ -- 'getEquivalence' f a b = 'getEquivalence' f b a -- @ -- -- __Transitivity__: -- -- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' then so is @'getEquivalence' f a c@ -- -- The types alone do not enforce these laws, so you'll have to check them yourself. newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool } #ifdef LANGUAGE_DeriveDataTypeable deriving Typeable #endif -- | Equivalence relations are 'Contravariant', because you can -- apply the contramapped function to each input to the equivalence -- relation. instance Contravariant Equivalence where contramap f g = Equivalence $ on (getEquivalence g) f #ifdef MIN_VERSION_semigroups instance Semigroup (Equivalence a) where Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b #endif instance Monoid (Equivalence a) where mempty = Equivalence (\_ _ -> True) mappend (Equivalence p) (Equivalence q) = Equivalence $ \a b -> p a b && q a b -- | Check for equivalence with '==' -- -- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@. defaultEquivalence :: Eq a => Equivalence a defaultEquivalence = Equivalence (==) comparisonEquivalence :: Comparison a -> Equivalence a comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ -- | Dual function arrows. newtype Op a b = Op { getOp :: b -> a } #ifdef LANGUAGE_DeriveDataTypeable deriving Typeable #endif instance Category Op where id = Op id Op f . Op g = Op (g . f) instance Contravariant (Op a) where contramap f g = Op (getOp g . f) #ifdef MIN_VERSION_semigroups instance Semigroup a => Semigroup (Op a b) where Op p <> Op q = Op $ \a -> p a <> q a #endif instance Monoid a => Monoid (Op a b) where mempty = Op (const mempty) mappend (Op p) (Op q) = Op $ \a -> mappend (p a) (q a) #if MIN_VERSION_base(4,5,0) instance Num a => Num (Op a b) where Op f + Op g = Op $ \a -> f a + g a Op f * Op g = Op $ \a -> f a * g a Op f - Op g = Op $ \a -> f a - g a abs (Op f) = Op $ abs . f signum (Op f) = Op $ signum . f fromInteger = Op . const . fromInteger instance Fractional a => Fractional (Op a b) where Op f / Op g = Op $ \a -> f a / g a recip (Op f) = Op $ recip . f fromRational = Op . const . fromRational instance Floating a => Floating (Op a b) where pi = Op $ const pi exp (Op f) = Op $ exp . f sqrt (Op f) = Op $ sqrt . f log (Op f) = Op $ log . f sin (Op f) = Op $ sin . f tan (Op f) = Op $ tan . f cos (Op f) = Op $ cos . f asin (Op f) = Op $ asin . f atan (Op f) = Op $ atan . f acos (Op f) = Op $ acos . f sinh (Op f) = Op $ sinh . f tanh (Op f) = Op $ tanh . f cosh (Op f) = Op $ cosh . f asinh (Op f) = Op $ asinh . f atanh (Op f) = Op $ atanh . f acosh (Op f) = Op $ acosh . f Op f ** Op g = Op $ \a -> f a ** g a logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a) #endif contravariant-1.4/src/Data/Functor/Contravariant/0000755000000000000000000000000012646536156020330 5ustar0000000000000000contravariant-1.4/src/Data/Functor/Contravariant/Compose.hs0000644000000000000000000000426212646536156022275 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Data.Functor.Contravariant.Compose -- Copyright : (c) Edward Kmett 2010 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : portable -- -- Composition of contravariant functors. module Data.Functor.Contravariant.Compose ( Compose(..) , ComposeFC(..) , ComposeCF(..) ) where import Control.Arrow #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible -- | Composition of two contravariant functors newtype Compose f g a = Compose { getCompose :: f (g a) } instance (Contravariant f, Contravariant g) => Functor (Compose f g) where fmap f (Compose x) = Compose (contramap (contramap f) x) -- | Composition of covariant and contravariant functors newtype ComposeFC f g a = ComposeFC { getComposeFC :: f (g a) } instance (Functor f, Contravariant g) => Contravariant (ComposeFC f g) where contramap f (ComposeFC x) = ComposeFC (fmap (contramap f) x) instance (Functor f, Functor g) => Functor (ComposeFC f g) where fmap f (ComposeFC x) = ComposeFC (fmap (fmap f) x) instance (Applicative f, Divisible g) => Divisible (ComposeFC f g) where conquer = ComposeFC $ pure conquer divide abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ divide abc <$> fb <*> fc instance (Applicative f, Decidable g) => Decidable (ComposeFC f g) where lose f = ComposeFC $ pure (lose f) choose abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ choose abc <$> fb <*> fc -- | Composition of contravariant and covariant functors newtype ComposeCF f g a = ComposeCF { getComposeCF :: f (g a) } instance (Contravariant f, Functor g) => Contravariant (ComposeCF f g) where contramap f (ComposeCF x) = ComposeCF (contramap (fmap f) x) instance (Functor f, Functor g) => Functor (ComposeCF f g) where fmap f (ComposeCF x) = ComposeCF (fmap (fmap f) x) instance (Divisible f, Applicative g) => Divisible (ComposeCF f g) where conquer = ComposeCF conquer divide abc (ComposeCF fb) (ComposeCF fc) = ComposeCF $ divide (funzip . fmap abc) fb fc funzip :: Functor f => f (a, b) -> (f a, f b) funzip = fmap fst &&& fmap snd contravariant-1.4/src/Data/Functor/Contravariant/Divisible.hs0000644000000000000000000004104712646536156022604 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant.Divisible -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module supplies contravariant analogues to the 'Applicative' and 'Alternative' classes. ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Divisible ( -- * Contravariant Applicative Divisible(..), divided, conquered, liftD -- * Contravariant Alternative , Decidable(..), chosen, lost ) where import Control.Applicative import Control.Applicative.Backwards import Control.Arrow import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict 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.Either import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Contravariant import Data.Functor.Product import Data.Functor.Reverse import Data.Void #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) #else import Data.Monoid (Monoid(..)) #endif #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) import Data.Proxy #endif #if MIN_VERSION_StateVar import Data.StateVar #endif #if __GLASGOW_HASKELL__ >= 702 #define GHC_GENERICS import GHC.Generics #endif -------------------------------------------------------------------------------- -- * Contravariant Applicative -------------------------------------------------------------------------------- -- | -- -- A 'Divisible' contravariant functor is the contravariant analogue of 'Applicative'. -- -- In denser jargon, a 'Divisible' contravariant functor is a monoid object in the category -- of presheaves from Hask to Hask, equipped with Day convolution mapping the Cartesian -- product of the source to the Cartesian product of the target. -- -- By way of contrast, an 'Applicative' functor can be viewed as a monoid object in the -- category of copresheaves from Hask to Hask, equipped with Day convolution mapping the -- Cartesian product of the source to the Cartesian product of the target. -- -- Given the canonical diagonal morphism: -- -- @ -- delta a = (a,a) -- @ -- -- @'divide' 'delta'@ should be associative with 'conquer' as a unit -- -- @ -- 'divide' 'delta' m 'conquer' = m -- 'divide' 'delta' 'conquer' m = m -- 'divide' 'delta' ('divide' 'delta' m n) o = 'divide' 'delta' m ('divide' 'delta' n o) -- @ -- -- With more general arguments you'll need to reassociate and project using the monoidal -- structure of the source category. (Here fst and snd are used in lieu of the more restricted -- lambda and rho, but this construction works with just a monoidal category.) -- -- @ -- 'divide' f m 'conquer' = 'contramap' ('fst' . f) m -- 'divide' f 'conquer' m = 'contramap' ('snd' . f) m -- 'divide' f ('divide' g m n) o = 'divide' f' m ('divide' 'id' n o) where -- f' a = case f a of (bc,d) -> case g bc of (b,c) -> (a,(b,c)) -- @ class Contravariant f => Divisible f where divide :: (a -> (b, c)) -> f b -> f c -> f a -- | The underlying theory would suggest that this should be: -- -- @ -- conquer :: (a -> ()) -> f a -- @ -- -- However, as we are working over a Cartesian category (Hask) and the Cartesian product, such an input -- morphism is uniquely determined to be @'const' 'mempty'@, so we elide it. conquer :: f a -- | -- @ -- 'divided' = 'divide' 'id' -- @ divided :: Divisible f => f a -> f b -> f (a, b) divided = divide id -- | Redundant, but provided for symmetry. -- -- @ -- 'conquered' = 'conquer' -- @ conquered :: Divisible f => f () conquered = conquer -- | -- This is the divisible analogue of 'liftA'. It gives a viable default definition for 'contramap' in terms -- of the members of 'Divisible'. -- -- @ -- 'liftD' f = 'divide' ((,) () . f) 'conquer' -- @ liftD :: Divisible f => (a -> b) -> f b -> f a liftD f = divide ((,) () . f) conquer instance Monoid r => Divisible (Op r) where divide f (Op g) (Op h) = Op $ \a -> case f a of (b, c) -> g b `mappend` h c conquer = Op $ const mempty instance Divisible Comparison where divide f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of (a',a'') -> case f b of (b',b'') -> g a' b' `mappend` h a'' b'' conquer = Comparison $ \_ _ -> EQ instance Divisible Equivalence where divide f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of (a',a'') -> case f b of (b',b'') -> g a' b' && h a'' b'' conquer = Equivalence $ \_ _ -> True instance Divisible Predicate where divide f (Predicate g) (Predicate h) = Predicate $ \a -> case f a of (b, c) -> g b && h c conquer = Predicate $ const True instance Monoid m => Divisible (Const m) where divide _ (Const a) (Const b) = Const (mappend a b) conquer = Const mempty #if MIN_VERSION_base(4,8,0) instance Divisible f => Divisible (Alt f) where divide f (Alt l) (Alt r) = Alt $ divide f l r conquer = Alt conquer #endif #ifdef GHC_GENERICS instance Divisible U1 where divide _ U1 U1 = U1 conquer = U1 instance Divisible f => Divisible (Rec1 f) where divide f (Rec1 l) (Rec1 r) = Rec1 $ divide f l r conquer = Rec1 conquer instance Divisible f => Divisible (M1 i c f) where divide f (M1 l) (M1 r) = M1 $ divide f l r conquer = M1 conquer instance (Divisible f, Divisible g) => Divisible (f :*: g) where divide f (l1 :*: r1) (l2 :*: r2) = divide f l1 l2 :*: divide f r1 r2 conquer = conquer :*: conquer instance (Applicative f, Divisible g) => Divisible (f :.: g) where divide f (Comp1 l) (Comp1 r) = Comp1 (divide f <$> l <*> r) conquer = Comp1 $ pure conquer #endif instance Divisible f => Divisible (Backwards f) where divide f (Backwards l) (Backwards r) = Backwards $ divide f l r conquer = Backwards conquer instance Divisible m => Divisible (ErrorT e m) where divide f (ErrorT l) (ErrorT r) = ErrorT $ divide (funzip . fmap f) l r conquer = ErrorT conquer instance Divisible m => Divisible (ExceptT e m) where divide f (ExceptT l) (ExceptT r) = ExceptT $ divide (funzip . fmap f) l r conquer = ExceptT conquer 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 (ListT m) where divide f (ListT l) (ListT r) = ListT $ divide (funzip . map f) l r conquer = ListT conquer instance Divisible m => Divisible (MaybeT m) where divide f (MaybeT l) (MaybeT r) = MaybeT $ divide (funzip . fmap f) l r conquer = MaybeT conquer instance Divisible m => Divisible (ReaderT r m) where divide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divide abc (rmb r) (rmc r) conquer = ReaderT $ \_ -> conquer instance Divisible m => Divisible (Lazy.RWST r w s m) where divide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> divide (\ ~(a, s', w) -> case abc a of ~(b, c) -> ((b, s', w), (c, s', w))) (rsmb r s) (rsmc r s) conquer = Lazy.RWST $ \_ _ -> conquer instance Divisible m => Divisible (Strict.RWST r w s m) where divide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> divide (\(a, s', w) -> case abc a of (b, c) -> ((b, s', w), (c, s', w))) (rsmb r s) (rsmc r s) conquer = Strict.RWST $ \_ _ -> conquer instance Divisible m => Divisible (Lazy.StateT s m) where divide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> divide (lazyFanout f) (l s) (r s) conquer = Lazy.StateT $ \_ -> conquer instance Divisible m => Divisible (Strict.StateT s m) where divide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> divide (strictFanout f) (l s) (r s) conquer = Strict.StateT $ \_ -> conquer instance Divisible m => Divisible (Lazy.WriterT w m) where divide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ divide (lazyFanout f) l r conquer = Lazy.WriterT conquer instance Divisible m => Divisible (Strict.WriterT w m) where divide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ divide (strictFanout f) l r conquer = Strict.WriterT conquer instance (Applicative f, Divisible g) => Divisible (Compose f g) where divide f (Compose l) (Compose r) = Compose (divide f <$> l <*> r) conquer = Compose $ pure conquer instance Monoid m => Divisible (Constant m) where divide _ (Constant l) (Constant r) = Constant $ mappend l r conquer = Constant mempty instance (Divisible f, Divisible g) => Divisible (Product f g) where divide f (Pair l1 r1) (Pair l2 r2) = Pair (divide f l1 l2) (divide f r1 r2) conquer = Pair conquer conquer instance Divisible f => Divisible (Reverse f) where divide f (Reverse l) (Reverse r) = Reverse $ divide f l r conquer = Reverse conquer #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) instance Divisible Proxy where divide _ Proxy Proxy = Proxy conquer = Proxy #endif #if MIN_VERSION_StateVar instance Divisible SettableStateVar where divide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of (b, c) -> l b >> r c conquer = SettableStateVar $ \_ -> return () #endif 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 'Divisible' contravariant functor is a monoid object in the category of presheaves -- from Hask to Hask, equipped with Day convolution mapping the cartesian product of the -- source to the Cartesian product of the target. -- -- @ -- 'choose' 'Left' m ('lose' f) = m -- 'choose' 'Right' ('lose' f) m = m -- 'choose' f ('choose' g m n) o = 'divide' f' m ('divide' 'id' n o) where -- f' bcd = 'either' ('either' 'id' ('Right' . 'Left') . g) ('Right' . 'Right') . f -- @ -- -- In addition, we expect the same kind of distributive law as is satisfied by the usual -- covariant 'Alternative', w.r.t 'Applicative', which should be fully formulated and -- added here at some point! class Divisible f => Decidable f where -- | The only way to win is not to play. lose :: (a -> Void) -> f a choose :: (a -> Either b c) -> f b -> f c -> f a -- | -- @ -- 'lost' = 'lose' 'id' -- @ lost :: Decidable f => f Void lost = lose id -- | -- @ -- 'chosen' = 'choose' 'id' -- @ chosen :: Decidable f => f b -> f c -> f (Either b c) chosen = choose id instance Decidable Comparison where lose f = Comparison $ \a _ -> absurd (f a) choose f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of Left c -> case f b of Left d -> g c d Right{} -> LT Right c -> case f b of Left{} -> GT Right d -> h c d instance Decidable Equivalence where lose f = Equivalence $ \a -> absurd (f a) choose f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of Left c -> case f b of Left d -> g c d Right{} -> False Right c -> case f b of Left{} -> False Right d -> h c d instance Decidable Predicate where lose f = Predicate $ \a -> absurd (f a) choose f (Predicate g) (Predicate h) = Predicate $ either g h . f instance Monoid r => Decidable (Op r) where lose f = Op $ absurd . f choose f (Op g) (Op h) = Op $ either g h . f #if MIN_VERSION_base(4,8,0) instance Decidable f => Decidable (Alt f) where lose = Alt . lose choose f (Alt l) (Alt r) = Alt $ choose f l r #endif #ifdef GHC_GENERICS instance Decidable U1 where lose _ = U1 choose _ U1 U1 = U1 instance Decidable f => Decidable (Rec1 f) where lose = Rec1 . lose choose f (Rec1 l) (Rec1 r) = Rec1 $ choose f l r instance Decidable f => Decidable (M1 i c f) where lose = M1 . lose choose f (M1 l) (M1 r) = M1 $ choose f l r instance (Decidable f, Decidable g) => Decidable (f :*: g) where lose f = lose f :*: lose f choose f (l1 :*: r1) (l2 :*: r2) = choose f l1 l2 :*: choose f r1 r2 instance (Applicative f, Decidable g) => Decidable (f :.: g) where lose = Comp1 . pure . lose choose f (Comp1 l) (Comp1 r) = Comp1 (choose f <$> l <*> r) #endif instance Decidable f => Decidable (Backwards f) where lose = Backwards . lose choose f (Backwards l) (Backwards r) = Backwards $ choose f l r instance Decidable f => Decidable (IdentityT f) where lose = IdentityT . lose choose f (IdentityT l) (IdentityT r) = IdentityT $ choose f l r instance Decidable m => Decidable (ReaderT r m) where lose f = ReaderT $ \_ -> lose f choose abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> choose abc (rmb r) (rmc r) instance Decidable m => Decidable (Lazy.RWST r w s m) where lose f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (lose f) choose abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> choose (\ ~(a, s', w) -> either (Left . betuple3 s' w) (Right . betuple3 s' w) (abc a)) (rsmb r s) (rsmc r s) instance Decidable m => Decidable (Strict.RWST r w s m) where lose f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (lose f) choose abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> choose (\(a, s', w) -> either (Left . betuple3 s' w) (Right . betuple3 s' w) (abc a)) (rsmb r s) (rsmc r s) instance Divisible m => Decidable (ListT m) where lose _ = ListT conquer choose f (ListT l) (ListT r) = ListT $ divide ((lefts &&& rights) . map f) l r instance Divisible m => Decidable (MaybeT m) where lose _ = MaybeT conquer choose f (MaybeT l) (MaybeT r) = MaybeT $ divide ( maybe (Nothing, Nothing) (either (\b -> (Just b, Nothing)) (\c -> (Nothing, Just c))) . fmap f) l r instance Decidable m => Decidable (Lazy.StateT s m) where lose f = Lazy.StateT $ \_ -> contramap lazyFst (lose f) choose f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> choose (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) (l s) (r s) instance Decidable m => Decidable (Strict.StateT s m) where lose f = Strict.StateT $ \_ -> contramap fst (lose f) choose f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> choose (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) (l s) (r s) instance Decidable m => Decidable (Lazy.WriterT w m) where lose f = Lazy.WriterT $ contramap lazyFst (lose f) choose f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ choose (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r instance Decidable m => Decidable (Strict.WriterT w m) where lose f = Strict.WriterT $ contramap fst (lose f) choose f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ choose (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r instance (Applicative f, Decidable g) => Decidable (Compose f g) where lose = Compose . pure . lose choose f (Compose l) (Compose r) = Compose (choose f <$> l <*> r) instance (Decidable f, Decidable g) => Decidable (Product f g) where lose f = Pair (lose f) (lose f) choose f (Pair l1 r1) (Pair l2 r2) = Pair (choose f l1 l2) (choose f r1 r2) instance Decidable f => Decidable (Reverse f) where lose = Reverse . lose choose f (Reverse l) (Reverse r) = Reverse $ choose f l r betuple :: s -> a -> (a, s) betuple s a = (a, s) betuple3 :: s -> w -> a -> (a, s, w) betuple3 s w a = (a, s, w) lazyFst :: (a, b) -> a lazyFst ~(a, _) = a #if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) instance Decidable Proxy where lose _ = Proxy choose _ Proxy Proxy = Proxy #endif #if MIN_VERSION_StateVar instance Decidable SettableVar where lose k = SettableStateVar (absurd . k) choose k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of Left b -> l b Right c -> r c #endif contravariant-1.4/src/Data/Functor/Contravariant/Generic.hs0000644000000000000000000001150712646536156022244 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef SAFE {-# LANGUAGE BangPatterns #-} #elif __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Contravariant.Generic -- Copyright : (C) 2007-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : ConstraintKinds -- -- -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Generic ( Deciding(..) , Deciding1(..) ) where import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import GHC.Generics #ifndef SAFE import Unsafe.Coerce #endif -- | This provides machinery for deconstructing an arbitrary 'Generic' instance using a 'Decidable' 'Contravariant' functor. -- -- /Examples:/ -- -- @ -- gcompare :: 'Deciding' 'Ord' a => a -> a -> 'Ordering' -- gcompare = 'getComparison' $ 'deciding' (Proxy :: Proxy 'Ord') ('Comparison' 'compare') -- @ -- -- @ -- geq :: 'Deciding' 'Eq' a => a -> a -> 'Bool' -- geq = 'getEquivalence' $ 'deciding' (Proxy :: Proxy 'Eq') ('Equivalence' ('==')) -- @ class (Generic a, GDeciding q (Rep a)) => Deciding q a where #ifndef HLINT deciding :: Decidable f => p q -> (forall b. q b => f b) -> f a #endif instance (Generic a, GDeciding q (Rep a)) => Deciding q a where deciding p q = contramap from $ gdeciding p q -- | This provides machinery for deconstructing an arbitrary 'Generic1' instance using a 'Decidable' 'Contravariant' functor. -- -- /Examples:/ -- -- @ -- gcompare1 :: 'Deciding1' 'Ord' f => (a -> a -> 'Ordering') -> f a -> f a -> 'Ordering' -- gcompare1 f = 'getComparison' $ 'deciding1' (Proxy :: Proxy 'Ord') ('Comparison' compare) ('Comparison' f) -- @ -- -- @ -- geq1 :: 'Deciding1' 'Eq' f => (a -> a -> 'Bool') -> f a -> f a -> 'Bool' -- geq1 f = 'getEquivalence' $ 'deciding1' (Proxy :: Proxy 'Eq') ('Equivalence' ('==')) ('Equivalence' f) -- @ class (Generic1 t, GDeciding1 q (Rep1 t)) => Deciding1 q t where #ifndef HLINT deciding1 :: Decidable f => p q -> (forall b. q b => f b) -> f a -> f (t a) #endif instance (Generic1 t, GDeciding1 q (Rep1 t)) => Deciding1 q t where deciding1 p q r = contramap from1 $ gdeciding1 p q r class GDeciding q t where #ifndef HLINT gdeciding :: Decidable f => p q -> (forall b. q b => f b) -> f (t a) #endif instance GDeciding q U1 where gdeciding _ _ = conquer instance GDeciding q V1 where gdeciding _ _ = 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) glose :: Decidable f => f (V1 a) #ifdef SAFE glose = lose (\ !_ -> error "impossible") #else glose = lose unsafeCoerce #endif {-# INLINE glose #-} gdivide :: Divisible f => f (g a) -> f (h a) -> f ((g:*:h) a) #ifdef SAFE gdivide = divide (\(f:*:g) -> (f,g)) #else gdivide = divide unsafeCoerce #endif {-# INLINE gdivide #-} gchoose :: Decidable f => f (g a) -> f (h a) -> f ((g:+:h) a) #ifdef SAFE gchoose = choose (\xs -> case xs of L1 a -> Left a; R1 b -> Right b) #else gchoose = choose unsafeCoerce #endif {-# 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)