{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

-- | `commit`
module Box.Committer
  ( Committer (..),
    CoCommitter,
    witherC,
    listC,
    push,
  )
where

import Box.Codensity (Codensity)
import Box.Functor
import Control.Monad.State.Lazy
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import qualified Data.Sequence as Seq
import Data.Void
import Prelude

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Prelude
-- >>> import Box
-- >>> import Data.Bool

-- | A Committer 'commit's values of type a and signals success or otherwise. A Sink and a Consumer are some other metaphors for this.
--
-- A Committer absorbs the value being committed; the value disappears into the opaque thing that is a Committer from the pov of usage.
--
-- >>> commit toStdout "I'm committed!"
-- I'm committed!
-- True
newtype Committer m a = Committer
  { forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit :: a -> m Bool
  }

-- | 'Committer' continuation.
type CoCommitter m a = Codensity m (Committer m a)

instance FFunctor Committer where
  foist :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Committer f a -> Committer g a
foist forall x. f x -> g x
nat (Committer a -> f Bool
c) = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ forall x. f x -> g x
nat forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f Bool
c

instance (Applicative m) => Semigroup (Committer m a) where
  <> :: Committer m a -> Committer m a -> Committer m a
(<>) Committer m a
i1 Committer m a
i2 = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (\a
a -> Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
i1 a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
i2 a
a)

instance (Applicative m) => Monoid (Committer m a) where
  mempty :: Committer m a
mempty = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (\a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

  mappend :: Committer m a -> Committer m a -> Committer m a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Contravariant (Committer m) where
  contramap :: forall a' a. (a' -> a) -> Committer m a -> Committer m a'
contramap a' -> a
f (Committer a -> m Bool
a) = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (a -> m Bool
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

instance (Applicative m) => Divisible (Committer m) where
  conquer :: forall a. Committer m a
conquer = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (\a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

  divide :: forall a b c.
(a -> (b, c)) -> Committer m b -> Committer m c -> Committer m a
divide a -> (b, c)
f Committer m b
i1 Committer m c
i2 =
    forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \a
a ->
      case a -> (b, c)
f a
a of
        (b
b, c
c) -> Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m b
i1 b
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m c
i2 c
c

instance (Applicative m) => Decidable (Committer m) where
  lose :: forall a. (a -> Void) -> Committer m a
lose a -> Void
f = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (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)
-> Committer m b -> Committer m c -> Committer m a
choose a -> Either b c
f Committer m b
i1 Committer m c
i2 =
    forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \a
a ->
      case a -> Either b c
f a
a of
        Left b
b -> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m b
i1 b
b
        Right c
c -> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m c
i2 c
c

-- | A monadic [Witherable](https://hackage.haskell.org/package/witherable)
--
-- >>> glue (witherC (\x -> pure $ bool Nothing (Just x) (even x)) showStdout) <$|> qList [0..5]
-- 0
-- 2
-- 4
witherC :: (Monad m) => (b -> m (Maybe a)) -> Committer m a -> Committer m b
witherC :: forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe a)) -> Committer m a -> Committer m b
witherC b -> m (Maybe a)
f Committer m a
c = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer b -> m Bool
go
  where
    go :: b -> m Bool
go b
b = do
      Maybe a
fb <- b -> m (Maybe a)
f b
b
      case Maybe a
fb of
        Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just a
fb' -> forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
c a
fb'

-- | Convert a committer to be a list committer.  Think mconcat.
--
-- >>> glue showStdout <$|> qList [[1..3]]
-- [1,2,3]
--
-- >>>  glue (listC showStdout) <$|> qList [[1..3]]
-- 1
-- 2
-- 3
listC :: (Monad m) => Committer m a -> Committer m [a]
listC :: forall (m :: * -> *) a. Monad m => Committer m a -> Committer m [a]
listC Committer m a
c = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
c)

-- | Push to a state sequence.
--
-- >>> import Control.Monad.State.Lazy
-- >>> import qualified Data.Sequence as Seq
-- >>> flip execStateT Seq.empty . glue push . foist lift <$|> qList [1..3]
-- fromList [1,2,3]
push :: (Monad m) => Committer (StateT (Seq.Seq a) m) a
push :: forall (m :: * -> *) a. Monad m => Committer (StateT (Seq a) m) a
push = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \a
a -> do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Seq a -> a -> Seq a
Seq.:|> a
a)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True