{-# LANGUAGE CPP                  #-}
{-# LANGUAGE TypeOperators        #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

-- |
-- Module      : Data.Functor.Contravariant.Conclude
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- The contravariant counterpart of 'Data.Functor.Plus': like 'Decidable',
-- but without needing a 'Divisible' constraint.  This is only a part of
-- this library currently for compatibility, until it is (hopefully) merged
-- into /semigroupoids/.
--
-- @since 0.3.0.0
module Data.Functor.Contravariant.Conclude (
    Conclude(..)
  , concluded
  ) where

import Control.Applicative.Backwards
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.Functor.Apply
import Data.Functor.Compose
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Decide
import Data.Functor.Contravariant.Divise
import Data.Functor.Contravariant.Divisible
import Data.Functor.Product
import Data.Functor.Reverse
import Data.Void

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#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

-- | The contravariant analogue of 'Data.Functor.Plus.Plus'.  Adds on to
-- 'Decide' the ability to express a combinator that rejects all input, to
-- act as the dead-end. Essentially 'Decidable' without a superclass
-- constraint on 'Divisible'.
--
-- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines
-- a consumer that cannot ever receive /any/ input.
--
-- Conclude acts as an identity with 'decide', because any decision that
-- involves 'conclude' must necessarily /always/ pick the other option.
--
-- That is, for, say,
--
-- @
-- 'decide' f x 'concluded'
-- @
--
-- @f@ is the deciding function that picks which of the inputs of @decide@
-- to direct input to; in the situation above, @f@ must /always/ direct all
-- input to @x@, and never 'concluded'.
--
-- Mathematically, a functor being an instance of 'Decide' means that it is
-- "monoidal" with respect to the contravariant "either-based" Day
-- convolution described in the documentation of 'Decide'.  On top of
-- 'Decide', it adds a way to construct an "identity" @conclude@ where
-- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@.
class Decide f => Conclude f where
    -- | The consumer that cannot ever receive /any/ input.
    conclude :: (a -> Void) -> f a

-- | A potentially more meaningful form of 'conclude', the consumer that cannot
-- ever receive /any/ input.  That is because it expects only input of type
-- 'Void', but such a type has no values.
--
-- @
-- 'concluded' = 'conclude' 'id'
-- @
concluded :: Conclude f => f Void
concluded :: f Void
concluded = (Void -> Void) -> f Void
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude Void -> Void
forall a. a -> a
id

instance Decidable f => Conclude (WrappedDivisible f) where
    conclude :: (a -> Void) -> WrappedDivisible f a
conclude f :: a -> Void
f = f a -> WrappedDivisible f a
forall k (f :: k -> *) (a :: k). f a -> WrappedDivisible f a
WrapDivisible ((a -> Void) -> f a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)

instance Conclude Comparison where conclude :: (a -> Void) -> Comparison a
conclude = (a -> Void) -> Comparison a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
instance Conclude Equivalence where conclude :: (a -> Void) -> Equivalence a
conclude = (a -> Void) -> Equivalence a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
instance Conclude Predicate where conclude :: (a -> Void) -> Predicate a
conclude = (a -> Void) -> Predicate a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
instance Conclude (Op r) where
  conclude :: (a -> Void) -> Op r a
conclude f :: a -> Void
f = (a -> r) -> Op r a
forall a b. (b -> a) -> Op a b
Op ((a -> r) -> Op r a) -> (a -> r) -> Op r a
forall a b. (a -> b) -> a -> b
$ Void -> r
forall a. Void -> a
absurd (Void -> r) -> (a -> Void) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
f

#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)
instance Conclude Proxy where conclude :: (a -> Void) -> Proxy a
conclude = (a -> Void) -> Proxy a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose
#endif

#ifdef MIN_VERSION_StateVar
instance Conclude SettableStateVar where conclude = lose
#endif

#if MIN_VERSION_base(4,8,0)
instance Conclude f => Conclude (Alt f) where
  conclude :: (a -> Void) -> Alt f a
conclude = f a -> Alt f a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (f a -> Alt f a) -> ((a -> Void) -> f a) -> (a -> Void) -> Alt f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude
#endif

#ifdef GHC_GENERICS
instance Conclude U1 where conclude :: (a -> Void) -> U1 a
conclude = (a -> Void) -> U1 a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose

instance Conclude f => Conclude (Rec1 f) where
  conclude :: (a -> Void) -> Rec1 f a
conclude = f a -> Rec1 f a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (f a -> Rec1 f a)
-> ((a -> Void) -> f a) -> (a -> Void) -> Rec1 f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

instance Conclude f => Conclude (M1 i c f) where
  conclude :: (a -> Void) -> M1 i c f a
conclude = f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 i c f a)
-> ((a -> Void) -> f a) -> (a -> Void) -> M1 i c f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

instance (Conclude f, Conclude g) => Conclude (f :*: g) where
  conclude :: (a -> Void) -> (:*:) f g a
conclude f :: a -> Void
f = (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: (a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f

instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where
  conclude :: (a -> Void) -> (:.:) f g a
conclude = f (g a) -> (:.:) f g a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g a) -> (:.:) f g a)
-> ((a -> Void) -> f (g a)) -> (a -> Void) -> (:.:) f g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> f (g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (g a -> f (g a)) -> ((a -> Void) -> g a) -> (a -> Void) -> f (g a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude
#endif

instance Conclude f => Conclude (Backwards f) where
  conclude :: (a -> Void) -> Backwards f a
conclude = f a -> Backwards f a
forall k (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (f a -> Backwards f a)
-> ((a -> Void) -> f a) -> (a -> Void) -> Backwards f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

instance Conclude f => Conclude (IdentityT f) where
  conclude :: (a -> Void) -> IdentityT f a
conclude = f a -> IdentityT f a
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT (f a -> IdentityT f a)
-> ((a -> Void) -> f a) -> (a -> Void) -> IdentityT f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

instance Conclude m => Conclude (ReaderT r m) where
  conclude :: (a -> Void) -> ReaderT r m a
conclude f :: a -> Void
f = (r -> m a) -> ReaderT r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m a) -> ReaderT r m a) -> (r -> m a) -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ \_ -> (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f

instance Conclude m => Conclude (Lazy.RWST r w s m) where
  conclude :: (a -> Void) -> RWST r w s m a
conclude f :: a -> Void
f = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Lazy.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \_ _ -> ((a, s, w) -> a) -> m a -> m (a, s, w)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\ ~(a :: a
a, _, _) -> a
a) ((a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

instance Conclude m => Conclude (Strict.RWST r w s m) where
  conclude :: (a -> Void) -> RWST r w s m a
conclude f :: a -> Void
f = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \_ _ -> ((a, s, w) -> a) -> m a -> m (a, s, w)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(a :: a
a, _, _) -> a
a) ((a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

instance (Divisible m, Divise m) => Conclude (ListT m) where
  conclude :: (a -> Void) -> ListT m a
conclude _ = m [a] -> ListT m a
forall (m :: * -> *) a. m [a] -> ListT m a
ListT m [a]
forall (f :: * -> *) a. Divisible f => f a
conquer

instance (Divisible m, Divise m) => Conclude (MaybeT m) where
  conclude :: (a -> Void) -> MaybeT m a
conclude _ = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe a)
forall (f :: * -> *) a. Divisible f => f a
conquer

instance Conclude m => Conclude (Lazy.StateT s m) where
  conclude :: (a -> Void) -> StateT s m a
conclude f :: a -> Void
f = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Lazy.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \_ -> ((a, s) -> a) -> m a -> m (a, s)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (a, s) -> a
forall a b. (a, b) -> a
lazyFst ((a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

instance Conclude m => Conclude (Strict.StateT s m) where
  conclude :: (a -> Void) -> StateT s m a
conclude f :: a -> Void
f = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \_ -> ((a, s) -> a) -> m a -> m (a, s)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (a, s) -> a
forall a b. (a, b) -> a
fst ((a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

instance Conclude m => Conclude (Lazy.WriterT w m) where
  conclude :: (a -> Void) -> WriterT w m a
conclude f :: a -> Void
f = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ ((a, w) -> a) -> m a -> m (a, w)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (a, w) -> a
forall a b. (a, b) -> a
lazyFst ((a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

instance Conclude m => Conclude (Strict.WriterT w m) where
  conclude :: (a -> Void) -> WriterT w m a
conclude f :: a -> Void
f = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ ((a, w) -> a) -> m a -> m (a, w)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (a, w) -> a
forall a b. (a, b) -> a
fst ((a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where
  conclude :: (a -> Void) -> Compose f g a
conclude = f (g a) -> Compose f g a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (f (g a) -> Compose f g a)
-> ((a -> Void) -> f (g a)) -> (a -> Void) -> Compose f g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> f (g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (g a -> f (g a)) -> ((a -> Void) -> g a) -> (a -> Void) -> f (g a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

instance (Conclude f, Conclude g) => Conclude (Product f g) where
  conclude :: (a -> Void) -> Product f g a
conclude f :: a -> Void
f = f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f) ((a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

instance Conclude f => Conclude (Reverse f) where
  conclude :: (a -> Void) -> Reverse f a
conclude = f a -> Reverse f a
forall k (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse (f a -> Reverse f a)
-> ((a -> Void) -> f a) -> (a -> Void) -> Reverse f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

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