{-# LANGUAGE CPP           #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2021 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- This module is only available if building with GHC 8.6 or later, or if the
-- @+contravariant@ @cabal@ build flag is available.
----------------------------------------------------------------------------
module Data.Functor.Contravariant.Conclude (
    Conclude(..)
  , gconclude
  , concluded
  , gconcluded
  ) where

import Control.Applicative.Backwards
import Control.Monad.Trans.Identity
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.Product
import Data.Functor.Reverse
import Data.Monoid (Alt(..))
import Data.Proxy
import Data.Void
import GHC.Generics

#if defined(MIN_VERSION_contravariant)
# if !(MIN_VERSION_transformers(0,6,0))
import Control.Monad.Trans.List
# endif
import Control.Monad.Trans.Maybe
import Data.Functor.Contravariant.Divise
import Data.Functor.Contravariant.Divisible
#endif

#ifdef MIN_VERSION_StateVar
import Data.StateVar
#endif

-- | The contravariant analogue of '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@.
--
-- @since 5.3.6
class Decide f => Conclude f where
    -- | The consumer that cannot ever receive /any/ input.
    conclude :: (a -> Void) -> f a

-- | Generic 'conclude'. Caveats:
--
--   1. Will not compile if @f@ is a sum type.
--   2. Will not compile if @f@ contains fields that do not mention its type variable.
--
-- @since 5.3.8
gconclude :: (Generic1 f, Conclude (Rep1 f)) => (a -> Void) -> f a
gconclude :: forall (f :: * -> *) a.
(Generic1 f, Conclude (Rep1 f)) =>
(a -> Void) -> f a
gconclude a -> Void
f = Rep1 f a -> f a
forall a. Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 f a -> f a) -> Rep1 f a -> f a
forall a b. (a -> b) -> a -> b
$ (a -> Void) -> Rep1 f a
forall a. (a -> Void) -> Rep1 f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f

-- | 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'
-- @
--
-- @since 5.3.6
concluded :: Conclude f => f Void
concluded :: forall (f :: * -> *). Conclude f => f Void
concluded = (Void -> Void) -> f Void
forall a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude Void -> Void
forall a. a -> a
id

-- | Generic 'concluded'. Caveats are the same as for 'gconclude'.
--
-- @since 5.3.8
gconcluded :: (Generic1 f, Conclude (Rep1 f)) => f Void
gconcluded :: forall (f :: * -> *). (Generic1 f, Conclude (Rep1 f)) => f Void
gconcluded = Rep1 f Void -> f Void
forall a. Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 Rep1 f Void
forall (f :: * -> *). Conclude f => f Void
concluded

#if defined(MIN_VERSION_contravariant)
-- | This instance is only available if the @+contravariant@ @cabal@ flag is
-- enabled.
--
-- @since 5.3.6
instance Decidable f => Conclude (WrappedDivisible f) where
    conclude :: forall a. (a -> Void) -> WrappedDivisible f a
conclude a -> Void
f = f a -> WrappedDivisible f a
forall (f :: * -> *) a. f a -> WrappedDivisible f a
WrapDivisible ((a -> Void) -> f a
forall a. (a -> Void) -> f a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
#endif

-- | @since 5.3.6
instance Conclude Comparison where
  conclude :: forall a. (a -> Void) -> Comparison a
conclude a -> Void
f = (a -> a -> Ordering) -> Comparison a
forall a. (a -> a -> Ordering) -> Comparison a
Comparison ((a -> a -> Ordering) -> Comparison a)
-> (a -> a -> Ordering) -> Comparison a
forall a b. (a -> b) -> a -> b
$ \a
a a
_ -> Void -> Ordering
forall a. Void -> a
absurd (a -> Void
f a
a)

-- | @since 5.3.6
instance Conclude Equivalence where
  conclude :: forall a. (a -> Void) -> Equivalence a
conclude a -> Void
f = (a -> a -> Bool) -> Equivalence a
forall a. (a -> a -> Bool) -> Equivalence a
Equivalence ((a -> a -> Bool) -> Equivalence a)
-> (a -> a -> Bool) -> Equivalence a
forall a b. (a -> b) -> a -> b
$ Void -> a -> Bool
forall a. Void -> a
absurd (Void -> a -> Bool) -> (a -> Void) -> a -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
f

-- | @since 5.3.6
instance Conclude Predicate where
  conclude :: forall a. (a -> Void) -> Predicate a
conclude a -> Void
f = (a -> Bool) -> Predicate a
forall a. (a -> Bool) -> Predicate a
Predicate ((a -> Bool) -> Predicate a) -> (a -> Bool) -> Predicate a
forall a b. (a -> b) -> a -> b
$ Void -> Bool
forall a. Void -> a
absurd (Void -> Bool) -> (a -> Void) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
f

-- | @since 5.3.6
instance Conclude (Op r) where
  conclude :: forall a. (a -> Void) -> Op r a
conclude 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

-- | @since 5.3.6
instance Conclude Proxy where
  conclude :: forall a. (a -> Void) -> Proxy a
conclude a -> Void
_ = Proxy a
forall {k} (t :: k). Proxy t
Proxy

#ifdef MIN_VERSION_StateVar
-- | @since 5.3.6
instance Conclude SettableStateVar where
  conclude k = SettableStateVar (absurd . k)
#endif

-- | @since 5.3.6
instance Conclude f => Conclude (Alt f) where
  conclude :: forall a. (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 a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- | @since 5.3.6
instance Conclude U1 where
  conclude :: forall a. (a -> Void) -> U1 a
conclude a -> Void
_ = U1 a
forall k (p :: k). U1 p
U1

-- | @since 5.3.6
instance Conclude f => Conclude (Rec1 f) where
  conclude :: forall a. (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 a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- | @since 5.3.6
instance Conclude f => Conclude (M1 i c f) where
  conclude :: forall a. (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 a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- | @since 5.3.6
instance (Conclude f, Conclude g) => Conclude (f :*: g) where
  conclude :: forall a. (a -> Void) -> (:*:) f g a
conclude a -> Void
f = (a -> Void) -> f a
forall a. (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 a. (a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f

-- | @since 5.3.6
instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where
  conclude :: forall a. (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 a. a -> f 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 a. (a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- | @since 5.3.6
instance Conclude f => Conclude (Backwards f) where
  conclude :: forall a. (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 a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- | @since 5.3.6
instance Conclude f => Conclude (IdentityT f) where
  conclude :: forall a. (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 a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- | @since 5.3.6
instance Conclude m => Conclude (ReaderT r m) where
  conclude :: forall a. (a -> Void) -> ReaderT r m a
conclude 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
$ \r
_ -> (a -> Void) -> m a
forall a. (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f

-- | @since 5.3.6
instance Conclude m => Conclude (Lazy.RWST r w s m) where
  conclude :: forall a. (a -> Void) -> RWST r w s m a
conclude 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
$ \r
_ s
_ -> ((a, s, w) -> a) -> m a -> m (a, s, w)
forall a' a. (a' -> a) -> m a -> m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\ ~(a
a, s
_, w
_) -> a
a) ((a -> Void) -> m a
forall a. (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

-- | @since 5.3.6
instance Conclude m => Conclude (Strict.RWST r w s m) where
  conclude :: forall a. (a -> Void) -> RWST r w s m a
conclude 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
$ \r
_ s
_ -> ((a, s, w) -> a) -> m a -> m (a, s, w)
forall a' a. (a' -> a) -> m a -> m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (\(a
a, s
_, w
_) -> a
a) ((a -> Void) -> m a
forall a. (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

#if defined(MIN_VERSION_contravariant)
# if !(MIN_VERSION_transformers(0,6,0))
-- | This instance is only available if the @+contravariant@ @cabal@ flag is
-- enabled.
--
-- @since 5.3.6
instance (Divisible m, Divise m) => Conclude (ListT m) where
  conclude _ = ListT conquer
# endif

-- | This instance is only available if the @+contravariant@ @cabal@ flag is
-- enabled.
--
-- @since 5.3.6
instance (Divisible m, Divise m) => Conclude (MaybeT m) where
  conclude :: forall a. (a -> Void) -> MaybeT m a
conclude a -> Void
_ = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe a)
forall a. m a
forall (f :: * -> *) a. Divisible f => f a
conquer
#endif

-- | @since 5.3.6
instance Conclude m => Conclude (Lazy.StateT s m) where
  conclude :: forall a. (a -> Void) -> StateT s m a
conclude 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
$ \s
_ -> ((a, s) -> a) -> m a -> m (a, s)
forall a' a. (a' -> a) -> m a -> m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (a, s) -> a
forall a b. (a, b) -> a
lazyFst ((a -> Void) -> m a
forall a. (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

-- | @since 5.3.6
instance Conclude m => Conclude (Strict.StateT s m) where
  conclude :: forall a. (a -> Void) -> StateT s m a
conclude 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
$ \s
_ -> ((a, s) -> a) -> m a -> m (a, s)
forall a' a. (a' -> a) -> m a -> m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (a, s) -> a
forall a b. (a, b) -> a
fst ((a -> Void) -> m a
forall a. (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

-- | @since 5.3.6
instance Conclude m => Conclude (Lazy.WriterT w m) where
  conclude :: forall a. (a -> Void) -> WriterT w m a
conclude 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 a' a. (a' -> a) -> m a -> m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (a, w) -> a
forall a b. (a, b) -> a
lazyFst ((a -> Void) -> m a
forall a. (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

-- | @since 5.3.6
instance Conclude m => Conclude (Strict.WriterT w m) where
  conclude :: forall a. (a -> Void) -> WriterT w m a
conclude 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 a' a. (a' -> a) -> m a -> m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (a, w) -> a
forall a b. (a, b) -> a
fst ((a -> Void) -> m a
forall a. (a -> Void) -> m a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

-- | @since 5.3.6
instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where
  conclude :: forall a. (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 a. a -> f 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 a. (a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- | @since 5.3.6
instance (Conclude f, Conclude g) => Conclude (Product f g) where
  conclude :: forall a. (a -> Void) -> Product f g a
conclude 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 a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f) ((a -> Void) -> g a
forall a. (a -> Void) -> g a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude a -> Void
f)

-- | @since 5.3.6
instance Conclude f => Conclude (Reverse f) where
  conclude :: forall a. (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 a. (a -> Void) -> f a
forall (f :: * -> *) a. Conclude f => (a -> Void) -> f a
conclude

-- Helpers

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