{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

#if !(MIN_VERSION_transformers(0,6,0))
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Contravariant.Divisible
-- Copyright   :  (C) 2014-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <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.Void

#if !(MIN_VERSION_transformers(0,6,0))
import Control.Monad.Trans.Error
import Control.Monad.Trans.List
import Data.Either
#endif

#if MIN_VERSION_base(4,8,0)
import Data.Monoid (Alt(..))
#else
import Data.Monoid (Monoid(..))
#endif

#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)
import Data.Proxy
#endif

#ifdef MIN_VERSION_StateVar
import Data.StateVar
#endif

#if __GLASGOW_HASKELL__ >= 702
#define GHC_GENERICS
import GHC.Generics
#endif

--------------------------------------------------------------------------------
-- * Contravariant Applicative
--------------------------------------------------------------------------------

-- |
--
-- A 'Divisible' contravariant functor is the contravariant analogue of 'Applicative'.
--
-- Continuing the intuition that 'Contravariant' functors consume input, a 'Divisible'
-- contravariant functor also has the ability to be composed "beside" another contravariant
-- functor.
--
-- Serializers provide a good example of 'Divisible' contravariant functors. To begin
-- let's start with the type of serializers for specific types:
--
-- @
-- newtype Serializer a = Serializer { runSerializer :: a -> ByteString }
-- @
--
-- This is a contravariant functor:
--
-- @
-- instance Contravariant Serializer where
--   contramap f s = Serializer (runSerializer s . f)
-- @
--
-- That is, given a serializer for @a@ (@s :: Serializer a@), and a way to turn
-- @b@s into @a@s (a mapping @f :: b -> a@), we have a serializer for @b@:
-- @contramap f s :: Serializer b@.
--
-- Divisible gives us a way to combine two serializers that focus on different
-- parts of a structure. If we postulate the existance of two primitive
-- serializers - @string :: Serializer String@ and @int :: Serializer Int@, we
-- would like to be able to combine these into a serializer for pairs of
-- @String@s and @Int@s. How can we do this? Simply run both serializers and
-- combine their output!
--
-- @
-- data StringAndInt = StringAndInt String Int
--
-- stringAndInt :: Serializer StringAndInt
-- stringAndInt = Serializer $ \\(StringAndInt s i) ->
--   let sBytes = runSerializer string s
--       iBytes = runSerializer int i
--   in sBytes <> iBytes
-- @
--
-- 'divide' is a generalization by also taking a 'contramap' like function to
-- split any @a@ into a pair. This conveniently allows you to target fields of
-- a record, for instance, by extracting the values under two fields and
-- combining them into a tuple.
--
-- To complete the example, here is how to write @stringAndInt@ using a
-- @Divisible@ instance:
--
-- @
-- instance Divisible Serializer where
--   conquer = Serializer (const mempty)
--
--   divide toBC bSerializer cSerializer = Serializer $ \\a ->
--     case toBC a of
--       (b, c) ->
--         let bBytes = runSerializer bSerializer b
--             cBytes = runSerializer cSerializer c
--         in bBytes <> cBytes
--
-- stringAndInt :: Serializer StringAndInt
-- stringAndInt =
--   divide (\\(StringAndInt s i) -> (s, i)) string int
-- @
--
class Contravariant f => Divisible f where
  --- | If one can handle split `a` into `(b, c)`, as well as handle `b`s and `c`s, then one can handle `a`s
  divide  :: (a -> (b, c)) -> f b -> f c -> f a

  -- | Conquer acts as an identity for combining @Divisible@ functors.
  conquer :: f a

-- |
-- @
-- 'divided' = 'divide' 'id'
-- @
divided :: Divisible f => f a -> f b -> f (a, b)
divided :: forall (f :: * -> *) a b. Divisible f => f a -> f b -> f (a, b)
divided = forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide forall a. a -> a
id

-- | Redundant, but provided for symmetry.
--
-- @
-- 'conquered' = 'conquer'
-- @
conquered :: Divisible f => f ()
conquered :: forall (f :: * -> *). Divisible f => f ()
conquered = forall (f :: * -> *) a. Divisible f => f a
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 :: forall (f :: * -> *) a b. Divisible f => (a -> b) -> f b -> f a
liftD a -> b
f = forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide ((,) () forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) forall (f :: * -> *) a. Divisible f => f a
conquer

instance Monoid r => Divisible (Op r) where
  divide :: forall a b c. (a -> (b, c)) -> Op r b -> Op r c -> Op r a
divide a -> (b, c)
f (Op b -> r
g) (Op c -> r
h) = forall a b. (b -> a) -> Op a b
Op forall a b. (a -> b) -> a -> b
$ \a
a -> case a -> (b, c)
f a
a of
    (b
b, c
c) -> b -> r
g b
b forall a. Monoid a => a -> a -> a
`mappend` c -> r
h c
c
  conquer :: forall a. Op r a
conquer = forall a b. (b -> a) -> Op a b
Op forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Monoid a => a
mempty

instance Divisible Comparison where
  divide :: forall a b c.
(a -> (b, c)) -> Comparison b -> Comparison c -> Comparison a
divide a -> (b, c)
f (Comparison b -> b -> Ordering
g) (Comparison c -> c -> Ordering
h) = forall a. (a -> a -> Ordering) -> Comparison a
Comparison forall a b. (a -> b) -> a -> b
$ \a
a a
b -> case a -> (b, c)
f a
a of
    (b
a',c
a'') -> case a -> (b, c)
f a
b of
      (b
b',c
b'') -> b -> b -> Ordering
g b
a' b
b' forall a. Monoid a => a -> a -> a
`mappend` c -> c -> Ordering
h c
a'' c
b''
  conquer :: forall a. Comparison a
conquer = forall a. (a -> a -> Ordering) -> Comparison a
Comparison forall a b. (a -> b) -> a -> b
$ \a
_ a
_ -> Ordering
EQ

instance Divisible Equivalence where
  divide :: forall a b c.
(a -> (b, c)) -> Equivalence b -> Equivalence c -> Equivalence a
divide a -> (b, c)
f (Equivalence b -> b -> Bool
g) (Equivalence c -> c -> Bool
h) = forall a. (a -> a -> Bool) -> Equivalence a
Equivalence forall a b. (a -> b) -> a -> b
$ \a
a a
b -> case a -> (b, c)
f a
a of
    (b
a',c
a'') -> case a -> (b, c)
f a
b of
      (b
b',c
b'') -> b -> b -> Bool
g b
a' b
b' Bool -> Bool -> Bool
&& c -> c -> Bool
h c
a'' c
b''
  conquer :: forall a. Equivalence a
conquer = forall a. (a -> a -> Bool) -> Equivalence a
Equivalence forall a b. (a -> b) -> a -> b
$ \a
_ a
_ -> Bool
True

instance Divisible Predicate where
  divide :: forall a b c.
(a -> (b, c)) -> Predicate b -> Predicate c -> Predicate a
divide a -> (b, c)
f (Predicate b -> Bool
g) (Predicate c -> Bool
h) = forall a. (a -> Bool) -> Predicate a
Predicate forall a b. (a -> b) -> a -> b
$ \a
a -> case a -> (b, c)
f a
a of
    (b
b, c
c) -> b -> Bool
g b
b Bool -> Bool -> Bool
&& c -> Bool
h c
c
  conquer :: forall a. Predicate a
conquer = forall a. (a -> Bool) -> Predicate a
Predicate forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True

instance Monoid m => Divisible (Const m) where
  divide :: forall a b c. (a -> (b, c)) -> Const m b -> Const m c -> Const m a
divide a -> (b, c)
_ (Const m
a) (Const m
b) = forall {k} a (b :: k). a -> Const a b
Const (forall a. Monoid a => a -> a -> a
mappend m
a m
b)
  conquer :: forall a. Const m a
conquer = forall {k} a (b :: k). a -> Const a b
Const forall a. Monoid a => a
mempty

#if MIN_VERSION_base(4,8,0)
instance Divisible f => Divisible (Alt f) where
  divide :: forall a b c. (a -> (b, c)) -> Alt f b -> Alt f c -> Alt f a
divide a -> (b, c)
f (Alt f b
l) (Alt f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l f c
r
  conquer :: forall a. Alt f a
conquer = forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt forall (f :: * -> *) a. Divisible f => f a
conquer
#endif

#ifdef GHC_GENERICS
instance Divisible U1 where
  divide :: forall a b c. (a -> (b, c)) -> U1 b -> U1 c -> U1 a
divide a -> (b, c)
_ U1 b
U1 U1 c
U1 = forall k (p :: k). U1 p
U1
  conquer :: forall a. U1 a
conquer = forall k (p :: k). U1 p
U1

instance Divisible f => Divisible (Rec1 f) where
  divide :: forall a b c. (a -> (b, c)) -> Rec1 f b -> Rec1 f c -> Rec1 f a
divide a -> (b, c)
f (Rec1 f b
l) (Rec1 f c
r) = forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l f c
r
  conquer :: forall a. Rec1 f a
conquer = forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible f => Divisible (M1 i c f) where
  divide :: forall a b c.
(a -> (b, c)) -> M1 i c f b -> M1 i c f c -> M1 i c f a
divide a -> (b, c)
f (M1 f b
l) (M1 f c
r) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l f c
r
  conquer :: forall a. M1 i c f a
conquer = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a. Divisible f => f a
conquer

instance (Divisible f, Divisible g) => Divisible (f :*: g) where
  divide :: forall a b c.
(a -> (b, c)) -> (:*:) f g b -> (:*:) f g c -> (:*:) f g a
divide a -> (b, c)
f (f b
l1 :*: g b
r1) (f c
l2 :*: g c
r2) = forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l1 f c
l2 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f g b
r1 g c
r2
  conquer :: forall a. (:*:) f g a
conquer = forall (f :: * -> *) a. Divisible f => f a
conquer forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. Divisible f => f a
conquer

instance (Applicative f, Divisible g) => Divisible (f :.: g) where
  divide :: forall a b c.
(a -> (b, c)) -> (:.:) f g b -> (:.:) f g c -> (:.:) f g a
divide a -> (b, c)
f (Comp1 f (g b)
l) (Comp1 f (g c)
r) = forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (g c)
r)
  conquer :: forall a. (:.:) f g a
conquer = forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Divisible f => f a
conquer
#endif

instance Divisible f => Divisible (Backwards f) where
  divide :: forall a b c.
(a -> (b, c)) -> Backwards f b -> Backwards f c -> Backwards f a
divide a -> (b, c)
f (Backwards f b
l) (Backwards f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l f c
r
  conquer :: forall a. Backwards f a
conquer = forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (ExceptT e m) where
  divide :: forall a b c.
(a -> (b, c)) -> ExceptT e m b -> ExceptT e m c -> ExceptT e m a
divide a -> (b, c)
f (ExceptT m (Either e b)
l) (ExceptT m (Either e c)
r) = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (b, c)
f) m (Either e b)
l m (Either e c)
r
  conquer :: forall a. ExceptT e m a
conquer = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible f => Divisible (IdentityT f) where
  divide :: forall a b c.
(a -> (b, c)) -> IdentityT f b -> IdentityT f c -> IdentityT f a
divide a -> (b, c)
f (IdentityT f b
l) (IdentityT f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l f c
r
  conquer :: forall a. IdentityT f a
conquer = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (MaybeT m) where
  divide :: forall a b c.
(a -> (b, c)) -> MaybeT m b -> MaybeT m c -> MaybeT m a
divide a -> (b, c)
f (MaybeT m (Maybe b)
l) (MaybeT m (Maybe c)
r) = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (b, c)
f) m (Maybe b)
l m (Maybe c)
r
  conquer :: forall a. MaybeT m a
conquer = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (ReaderT r m) where
  divide :: forall a b c.
(a -> (b, c)) -> ReaderT r m b -> ReaderT r m c -> ReaderT r m a
divide a -> (b, c)
abc (ReaderT r -> m b
rmb) (ReaderT r -> m c
rmc) = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r -> forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
abc (r -> m b
rmb r
r) (r -> m c
rmc r
r)
  conquer :: forall a. ReaderT r m a
conquer = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
_ -> forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (Lazy.RWST r w s m) where
  divide :: forall a b c.
(a -> (b, c)) -> RWST r w s m b -> RWST r w s m c -> RWST r w s m a
divide a -> (b, c)
abc (Lazy.RWST r -> s -> m (b, s, w)
rsmb) (Lazy.RWST r -> s -> m (c, s, w)
rsmc) = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Lazy.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s ->
    forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\ ~(a
a, s
s', w
w) -> case a -> (b, c)
abc a
a of
                                  ~(b
b, c
c) -> ((b
b, s
s', w
w), (c
c, s
s', w
w)))
           (r -> s -> m (b, s, w)
rsmb r
r s
s) (r -> s -> m (c, s, w)
rsmc r
r s
s)
  conquer :: forall a. RWST r w s m a
conquer = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Lazy.RWST forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (Strict.RWST r w s m) where
  divide :: forall a b c.
(a -> (b, c)) -> RWST r w s m b -> RWST r w s m c -> RWST r w s m a
divide a -> (b, c)
abc (Strict.RWST r -> s -> m (b, s, w)
rsmb) (Strict.RWST r -> s -> m (c, s, w)
rsmc) = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s ->
    forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\(a
a, s
s', w
w) -> case a -> (b, c)
abc a
a of
                                (b
b, c
c) -> ((b
b, s
s', w
w), (c
c, s
s', w
w)))
           (r -> s -> m (b, s, w)
rsmb r
r s
s) (r -> s -> m (c, s, w)
rsmc r
r s
s)
  conquer :: forall a. RWST r w s m a
conquer = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (Lazy.StateT s m) where
  divide :: forall a b c.
(a -> (b, c)) -> StateT s m b -> StateT s m c -> StateT s m a
divide a -> (b, c)
f (Lazy.StateT s -> m (b, s)
l) (Lazy.StateT s -> m (c, s)
r) = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Lazy.StateT forall a b. (a -> b) -> a -> b
$ \s
s ->
    forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall a b c s. (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
lazyFanout a -> (b, c)
f) (s -> m (b, s)
l s
s) (s -> m (c, s)
r s
s)
  conquer :: forall a. StateT s m a
conquer = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Lazy.StateT forall a b. (a -> b) -> a -> b
$ \s
_ -> forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (Strict.StateT s m) where
  divide :: forall a b c.
(a -> (b, c)) -> StateT s m b -> StateT s m c -> StateT s m a
divide a -> (b, c)
f (Strict.StateT s -> m (b, s)
l) (Strict.StateT s -> m (c, s)
r) = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT forall a b. (a -> b) -> a -> b
$ \s
s ->
    forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall a b c s. (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
strictFanout a -> (b, c)
f) (s -> m (b, s)
l s
s) (s -> m (c, s)
r s
s)
  conquer :: forall a. StateT s m a
conquer = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT forall a b. (a -> b) -> a -> b
$ \s
_ -> forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (Lazy.WriterT w m) where
  divide :: forall a b c.
(a -> (b, c)) -> WriterT w m b -> WriterT w m c -> WriterT w m a
divide a -> (b, c)
f (Lazy.WriterT m (b, w)
l) (Lazy.WriterT m (c, w)
r) = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall a b c s. (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
lazyFanout a -> (b, c)
f) m (b, w)
l m (c, w)
r
  conquer :: forall a. WriterT w m a
conquer = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (Strict.WriterT w m) where
  divide :: forall a b c.
(a -> (b, c)) -> WriterT w m b -> WriterT w m c -> WriterT w m a
divide a -> (b, c)
f (Strict.WriterT m (b, w)
l) (Strict.WriterT m (c, w)
r) = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall a b c s. (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
strictFanout a -> (b, c)
f) m (b, w)
l m (c, w)
r
  conquer :: forall a. WriterT w m a
conquer = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT forall (f :: * -> *) a. Divisible f => f a
conquer

instance (Applicative f, Divisible g) => Divisible (Compose f g) where
  divide :: forall a b c.
(a -> (b, c)) -> Compose f g b -> Compose f g c -> Compose f g a
divide a -> (b, c)
f (Compose f (g b)
l) (Compose f (g c)
r) = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (g c)
r)
  conquer :: forall a. Compose f g a
conquer = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Divisible f => f a
conquer

instance Monoid m => Divisible (Constant m) where
  divide :: forall a b c.
(a -> (b, c)) -> Constant m b -> Constant m c -> Constant m a
divide a -> (b, c)
_ (Constant m
l) (Constant m
r) = forall {k} a (b :: k). a -> Constant a b
Constant forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend m
l m
r
  conquer :: forall a. Constant m a
conquer = forall {k} a (b :: k). a -> Constant a b
Constant forall a. Monoid a => a
mempty

instance (Divisible f, Divisible g) => Divisible (Product f g) where
  divide :: forall a b c.
(a -> (b, c)) -> Product f g b -> Product f g c -> Product f g a
divide a -> (b, c)
f (Pair f b
l1 g b
r1) (Pair f c
l2 g c
r2) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l1 f c
l2) (forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f g b
r1 g c
r2)
  conquer :: forall a. Product f g a
conquer = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair forall (f :: * -> *) a. Divisible f => f a
conquer forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible f => Divisible (Reverse f) where
  divide :: forall a b c.
(a -> (b, c)) -> Reverse f b -> Reverse f c -> Reverse f a
divide a -> (b, c)
f (Reverse f b
l) (Reverse f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
f f b
l f c
r
  conquer :: forall a. Reverse f a
conquer = forall {k} (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse forall (f :: * -> *) a. Divisible f => f a
conquer

#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)
instance Divisible Proxy where
  divide :: forall a b c. (a -> (b, c)) -> Proxy b -> Proxy c -> Proxy a
divide a -> (b, c)
_ Proxy b
Proxy Proxy c
Proxy = forall {k} (t :: k). Proxy t
Proxy
  conquer :: forall a. Proxy a
conquer = forall {k} (t :: k). Proxy t
Proxy
#endif

#ifdef MIN_VERSION_StateVar
instance Divisible SettableStateVar where
  divide :: forall a b c.
(a -> (b, c))
-> SettableStateVar b -> SettableStateVar c -> SettableStateVar a
divide a -> (b, c)
k (SettableStateVar b -> IO ()
l) (SettableStateVar c -> IO ()
r) = forall a. (a -> IO ()) -> SettableStateVar a
SettableStateVar forall a b. (a -> b) -> a -> b
$ \ a
a -> case a -> (b, c)
k a
a of
    (b
b, c
c) -> b -> IO ()
l b
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> IO ()
r c
c
  conquer :: forall a. SettableStateVar a
conquer = forall a. (a -> IO ()) -> SettableStateVar a
SettableStateVar forall a b. (a -> b) -> a -> b
$ \a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
lazyFanout :: forall a b c s. (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
lazyFanout a -> (b, c)
f ~(a
a, s
s) = case a -> (b, c)
f a
a of
  ~(b
b, c
c) -> ((b
b, s
s), (c
c, s
s))

strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
strictFanout :: forall a b c s. (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))
strictFanout a -> (b, c)
f (a
a, s
s) = case a -> (b, c)
f a
a of
  (b
b, c
c) -> ((b
b, s
s), (c
c, s
s))

funzip :: Functor f => f (a, b) -> (f a, f b)
funzip :: forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
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 :: forall (f :: * -> *). Decidable f => f Void
lost = forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose forall a. a -> a
id

-- |
-- @
-- 'chosen' = 'choose' 'id'
-- @
chosen :: Decidable f => f b -> f c -> f (Either b c)
chosen :: forall (f :: * -> *) b c.
Decidable f =>
f b -> f c -> f (Either b c)
chosen = forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose forall a. a -> a
id

instance Decidable Comparison where
  lose :: forall a. (a -> Void) -> Comparison a
lose a -> Void
f = forall a. (a -> a -> Ordering) -> Comparison a
Comparison forall a b. (a -> b) -> a -> b
$ \a
a a
_ -> forall a. Void -> a
absurd (a -> Void
f a
a)
  choose :: forall a b c.
(a -> Either b c) -> Comparison b -> Comparison c -> Comparison a
choose a -> Either b c
f (Comparison b -> b -> Ordering
g) (Comparison c -> c -> Ordering
h) = forall a. (a -> a -> Ordering) -> Comparison a
Comparison forall a b. (a -> b) -> a -> b
$ \a
a a
b -> case a -> Either b c
f a
a of
    Left b
c -> case a -> Either b c
f a
b of
      Left b
d -> b -> b -> Ordering
g b
c b
d
      Right{} -> Ordering
LT
    Right c
c -> case a -> Either b c
f a
b of
      Left{} -> Ordering
GT
      Right c
d -> c -> c -> Ordering
h c
c c
d

instance Decidable Equivalence where
  lose :: forall a. (a -> Void) -> Equivalence a
lose a -> Void
f = forall a. (a -> a -> Bool) -> Equivalence a
Equivalence forall a b. (a -> b) -> a -> b
$ forall a. Void -> a
absurd forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
f
  choose :: forall a b c.
(a -> Either b c)
-> Equivalence b -> Equivalence c -> Equivalence a
choose a -> Either b c
f (Equivalence b -> b -> Bool
g) (Equivalence c -> c -> Bool
h) = forall a. (a -> a -> Bool) -> Equivalence a
Equivalence forall a b. (a -> b) -> a -> b
$ \a
a a
b -> case a -> Either b c
f a
a of
    Left b
c -> case a -> Either b c
f a
b of
      Left b
d -> b -> b -> Bool
g b
c b
d
      Right{} -> Bool
False
    Right c
c -> case a -> Either b c
f a
b of
      Left{} -> Bool
False
      Right c
d -> c -> c -> Bool
h c
c c
d

instance Decidable Predicate where
  lose :: forall a. (a -> Void) -> Predicate a
lose a -> Void
f = forall a. (a -> Bool) -> Predicate a
Predicate forall a b. (a -> b) -> a -> b
$ forall a. Void -> a
absurd forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
f
  choose :: forall a b c.
(a -> Either b c) -> Predicate b -> Predicate c -> Predicate a
choose a -> Either b c
f (Predicate b -> Bool
g) (Predicate c -> Bool
h) = forall a. (a -> Bool) -> Predicate a
Predicate forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> Bool
g c -> Bool
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b c
f

instance Monoid r => Decidable (Op r) where
  lose :: forall a. (a -> Void) -> Op r a
lose a -> Void
f = forall a b. (b -> a) -> Op a b
Op forall a b. (a -> b) -> a -> b
$ forall a. Void -> a
absurd forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
f
  choose :: forall a b c. (a -> Either b c) -> Op r b -> Op r c -> Op r a
choose a -> Either b c
f (Op b -> r
g) (Op c -> r
h) = forall a b. (b -> a) -> Op a b
Op forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> r
g c -> r
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b c
f

#if MIN_VERSION_base(4,8,0)
instance Decidable f => Decidable (Alt f) where
  lose :: forall a. (a -> Void) -> Alt f a
lose = forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c. (a -> Either b c) -> Alt f b -> Alt f c -> Alt f a
choose a -> Either b c
f (Alt f b
l) (Alt f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l f c
r
#endif

#ifdef GHC_GENERICS
instance Decidable U1 where
  lose :: forall a. (a -> Void) -> U1 a
lose a -> Void
_ = forall k (p :: k). U1 p
U1
  choose :: forall a b c. (a -> Either b c) -> U1 b -> U1 c -> U1 a
choose a -> Either b c
_ U1 b
U1 U1 c
U1 = forall k (p :: k). U1 p
U1

instance Decidable f => Decidable (Rec1 f) where
  lose :: forall a. (a -> Void) -> Rec1 f a
lose = forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c. (a -> Either b c) -> Rec1 f b -> Rec1 f c -> Rec1 f a
choose a -> Either b c
f (Rec1 f b
l) (Rec1 f c
r) = forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l f c
r

instance Decidable f => Decidable (M1 i c f) where
  lose :: forall a. (a -> Void) -> M1 i c f a
lose = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c.
(a -> Either b c) -> M1 i c f b -> M1 i c f c -> M1 i c f a
choose a -> Either b c
f (M1 f b
l) (M1 f c
r) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l f c
r

instance (Decidable f, Decidable g) => Decidable (f :*: g) where
  lose :: forall a. (a -> Void) -> (:*:) f g a
lose a -> Void
f = forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f
  choose :: forall a b c.
(a -> Either b c) -> (:*:) f g b -> (:*:) f g c -> (:*:) f g a
choose a -> Either b c
f (f b
l1 :*: g b
r1) (f c
l2 :*: g c
r2) = forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l1 f c
l2 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f g b
r1 g c
r2

instance (Applicative f, Decidable g) => Decidable (f :.: g) where
  lose :: forall a. (a -> Void) -> (:.:) f g a
lose = forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c.
(a -> Either b c) -> (:.:) f g b -> (:.:) f g c -> (:.:) f g a
choose a -> Either b c
f (Comp1 f (g b)
l) (Comp1 f (g c)
r) = forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (g c)
r)
#endif

instance Decidable f => Decidable (Backwards f) where
  lose :: forall a. (a -> Void) -> Backwards f a
lose = forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c.
(a -> Either b c)
-> Backwards f b -> Backwards f c -> Backwards f a
choose a -> Either b c
f (Backwards f b
l) (Backwards f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l f c
r

instance Decidable f => Decidable (IdentityT f) where
  lose :: forall a. (a -> Void) -> IdentityT f a
lose = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c.
(a -> Either b c)
-> IdentityT f b -> IdentityT f c -> IdentityT f a
choose a -> Either b c
f (IdentityT f b
l) (IdentityT f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l f c
r

instance Decidable m => Decidable (ReaderT r m) where
  lose :: forall a. (a -> Void) -> ReaderT r m a
lose a -> Void
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
_ -> forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f
  choose :: forall a b c.
(a -> Either b c)
-> ReaderT r m b -> ReaderT r m c -> ReaderT r m a
choose a -> Either b c
abc (ReaderT r -> m b
rmb) (ReaderT r -> m c
rmc) = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r -> forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
abc (r -> m b
rmb r
r) (r -> m c
rmc r
r)

instance Decidable m => Decidable (Lazy.RWST r w s m) where
  lose :: forall a. (a -> Void) -> RWST r w s m a
lose a -> Void
f = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Lazy.RWST forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\ ~(a
a, s
_, w
_) -> a
a) (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c)
-> RWST r w s m b -> RWST r w s m c -> RWST r w s m a
choose a -> Either b c
abc (Lazy.RWST r -> s -> m (b, s, w)
rsmb) (Lazy.RWST r -> s -> m (c, s, w)
rsmc) = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Lazy.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s ->
    forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose (\ ~(a
a, s
s', w
w) -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s w a. s -> w -> a -> (a, s, w)
betuple3 s
s' w
w)
                                    (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s w a. s -> w -> a -> (a, s, w)
betuple3 s
s' w
w)
                                    (a -> Either b c
abc a
a))
           (r -> s -> m (b, s, w)
rsmb r
r s
s) (r -> s -> m (c, s, w)
rsmc r
r s
s)

instance Decidable m => Decidable (Strict.RWST r w s m) where
  lose :: forall a. (a -> Void) -> RWST r w s m a
lose a -> Void
f = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\(a
a, s
_, w
_) -> a
a) (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c)
-> RWST r w s m b -> RWST r w s m c -> RWST r w s m a
choose a -> Either b c
abc (Strict.RWST r -> s -> m (b, s, w)
rsmb) (Strict.RWST r -> s -> m (c, s, w)
rsmc) = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s ->
    forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose (\(a
a, s
s', w
w) -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s w a. s -> w -> a -> (a, s, w)
betuple3 s
s' w
w)
                                  (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s w a. s -> w -> a -> (a, s, w)
betuple3 s
s' w
w)
                                  (a -> Either b c
abc a
a))
           (r -> s -> m (b, s, w)
rsmb r
r s
s) (r -> s -> m (c, s, w)
rsmc r
r s
s)

#if !(MIN_VERSION_transformers(0,6,0))
instance Divisible m => Divisible (ErrorT e m) where
  divide :: forall a b c.
(a -> (b, c)) -> ErrorT e m b -> ErrorT e m c -> ErrorT e m a
divide a -> (b, c)
f (ErrorT m (Either e b)
l) (ErrorT m (Either e c)
r) = forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (b, c)
f) m (Either e b)
l m (Either e c)
r
  conquer :: forall a. ErrorT e m a
conquer = forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Divisible (ListT m) where
  divide :: forall a b c. (a -> (b, c)) -> ListT m b -> ListT m c -> ListT m a
divide a -> (b, c)
f (ListT m [b]
l) (ListT m [c]
r) = forall (m :: * -> *) a. m [a] -> ListT m a
ListT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> (b, c)
f) m [b]
l m [c]
r
  conquer :: forall a. ListT m a
conquer = forall (m :: * -> *) a. m [a] -> ListT m a
ListT forall (f :: * -> *) a. Divisible f => f a
conquer

instance Divisible m => Decidable (ListT m) where
  lose :: forall a. (a -> Void) -> ListT m a
lose a -> Void
_ = forall (m :: * -> *) a. m [a] -> ListT m a
ListT forall (f :: * -> *) a. Divisible f => f a
conquer
  choose :: forall a b c.
(a -> Either b c) -> ListT m b -> ListT m c -> ListT m a
choose a -> Either b c
f (ListT m [b]
l) (ListT m [c]
r) = forall (m :: * -> *) a. m [a] -> ListT m a
ListT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide ((forall a b. [Either a b] -> [a]
lefts forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. [Either a b] -> [b]
rights) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> Either b c
f) m [b]
l m [c]
r
#endif

instance Divisible m => Decidable (MaybeT m) where
  lose :: forall a. (a -> Void) -> MaybeT m a
lose a -> Void
_ = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall (f :: * -> *) a. Divisible f => f a
conquer
  choose :: forall a b c.
(a -> Either b c) -> MaybeT m b -> MaybeT m c -> MaybeT m a
choose a -> Either b c
f (MaybeT m (Maybe b)
l) (MaybeT m (Maybe c)
r) = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide ( forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
                   (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\b
b -> (forall a. a -> Maybe a
Just b
b, forall a. Maybe a
Nothing))
                           (\c
c -> (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just c
c)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b c
f)
           ) m (Maybe b)
l m (Maybe c)
r

instance Decidable m => Decidable (Lazy.StateT s m) where
  lose :: forall a. (a -> Void) -> StateT s m a
lose a -> Void
f = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Lazy.StateT forall a b. (a -> b) -> a -> b
$ \s
_ -> forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a b. (a, b) -> a
lazyFst (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c) -> StateT s m b -> StateT s m c -> StateT s m a
choose a -> Either b c
f (Lazy.StateT s -> m (b, s)
l) (Lazy.StateT s -> m (c, s)
r) = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Lazy.StateT forall a b. (a -> b) -> a -> b
$ \s
s ->
    forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose (\ ~(a
a, s
s') -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple s
s') (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple s
s') (a -> Either b c
f a
a))
           (s -> m (b, s)
l s
s) (s -> m (c, s)
r s
s)

instance Decidable m => Decidable (Strict.StateT s m) where
  lose :: forall a. (a -> Void) -> StateT s m a
lose a -> Void
f = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT forall a b. (a -> b) -> a -> b
$ \s
_ -> forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a b. (a, b) -> a
fst (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c) -> StateT s m b -> StateT s m c -> StateT s m a
choose a -> Either b c
f (Strict.StateT s -> m (b, s)
l) (Strict.StateT s -> m (c, s)
r) = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT forall a b. (a -> b) -> a -> b
$ \s
s ->
    forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose (\(a
a, s
s') -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple s
s') (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple s
s') (a -> Either b c
f a
a))
           (s -> m (b, s)
l s
s) (s -> m (c, s)
r s
s)

instance Decidable m => Decidable (Lazy.WriterT w m) where
  lose :: forall a. (a -> Void) -> WriterT w m a
lose a -> Void
f = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a b. (a, b) -> a
lazyFst (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c)
-> WriterT w m b -> WriterT w m c -> WriterT w m a
choose a -> Either b c
f (Lazy.WriterT m (b, w)
l) (Lazy.WriterT m (c, w)
r) = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose (\ ~(a
a, w
s') -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple w
s') (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple w
s') (a -> Either b c
f a
a)) m (b, w)
l m (c, w)
r

instance Decidable m => Decidable (Strict.WriterT w m) where
  lose :: forall a. (a -> Void) -> WriterT w m a
lose a -> Void
f = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a b. (a, b) -> a
fst (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c)
-> WriterT w m b -> WriterT w m c -> WriterT w m a
choose a -> Either b c
f (Strict.WriterT m (b, w)
l) (Strict.WriterT m (c, w)
r) = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose (\(a
a, w
s') -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple w
s') (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> (a, s)
betuple w
s') (a -> Either b c
f a
a)) m (b, w)
l m (c, w)
r

instance (Applicative f, Decidable g) => Decidable (Compose f g) where
  lose :: forall a. (a -> Void) -> Compose f g a
lose = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c.
(a -> Either b c)
-> Compose f g b -> Compose f g c -> Compose f g a
choose a -> Either b c
f (Compose f (g b)
l) (Compose f (g c)
r) = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (g c)
r)

instance (Decidable f, Decidable g) => Decidable (Product f g) where
  lose :: forall a. (a -> Void) -> Product f g a
lose a -> Void
f = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f) (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c)
-> Product f g b -> Product f g c -> Product f g a
choose a -> Either b c
f (Pair f b
l1 g b
r1) (Pair f c
l2 g c
r2) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l1 f c
l2) (forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f g b
r1 g c
r2)

instance Decidable f => Decidable (Reverse f) where
  lose :: forall a. (a -> Void) -> Reverse f a
lose = forall {k} (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
  choose :: forall a b c.
(a -> Either b c) -> Reverse f b -> Reverse f c -> Reverse f a
choose a -> Either b c
f (Reverse f b
l) (Reverse f c
r) = forall {k} (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
f f b
l f c
r

betuple :: s -> a -> (a, s)
betuple :: forall s a. s -> a -> (a, s)
betuple s
s a
a = (a
a, s
s)

betuple3 :: s -> w -> a -> (a, s, w)
betuple3 :: forall s w a. s -> w -> a -> (a, s, w)
betuple3 s
s w
w a
a = (a
a, s
s, w
w)

lazyFst :: (a, b) -> a
lazyFst :: forall a b. (a, b) -> a
lazyFst ~(a
a, b
_) = a
a

#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)
instance Decidable Proxy where
  lose :: forall a. (a -> Void) -> Proxy a
lose a -> Void
_ = forall {k} (t :: k). Proxy t
Proxy
  choose :: forall a b c. (a -> Either b c) -> Proxy b -> Proxy c -> Proxy a
choose a -> Either b c
_ Proxy b
Proxy Proxy c
Proxy = forall {k} (t :: k). Proxy t
Proxy
#endif

#ifdef MIN_VERSION_StateVar
instance Decidable SettableStateVar where
  lose :: forall a. (a -> Void) -> SettableStateVar a
lose a -> Void
k = forall a. (a -> IO ()) -> SettableStateVar a
SettableStateVar (forall a. Void -> a
absurd forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
k)
  choose :: forall a b c.
(a -> Either b c)
-> SettableStateVar b -> SettableStateVar c -> SettableStateVar a
choose a -> Either b c
k (SettableStateVar b -> IO ()
l) (SettableStateVar c -> IO ()
r) = forall a. (a -> IO ()) -> SettableStateVar a
SettableStateVar forall a b. (a -> b) -> a -> b
$ \ a
a -> case a -> Either b c
k a
a of
    Left b
b -> b -> IO ()
l b
b
    Right c
c -> c -> IO ()
r c
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!