{-# 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 Control.Monad.State.Lazy
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import qualified Data.Sequence as Seq
import Data.Void
import Prelude
import Box.Codensity (Codensity)
import Box.Functor

-- $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
  { 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 x. f x -> g x) -> Committer f a -> Committer g a
foist forall x. f x -> g x
nat (Committer a -> f Bool
c) = (a -> g Bool) -> Committer g a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((a -> g Bool) -> Committer g a) -> (a -> g Bool) -> Committer g a
forall a b. (a -> b) -> a -> b
$ f Bool -> g Bool
forall x. f x -> g x
nat (f Bool -> g Bool) -> (a -> f Bool) -> a -> g Bool
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 = (a -> m Bool) -> Committer m a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (\a
a -> Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> m Bool -> m (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Committer m a -> a -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
i1 a
a m (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Committer m a -> a -> m Bool
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 = (a -> m Bool) -> Committer m a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (\a
_ -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

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

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

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

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

instance (Applicative m) => Decidable (Committer m) where
  lose :: (a -> Void) -> Committer m a
lose a -> Void
f = (a -> m Bool) -> Committer m a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (Void -> m Bool
forall a. Void -> a
absurd (Void -> m Bool) -> (a -> Void) -> a -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Void
f)

  choose :: (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 =
    (a -> m Bool) -> Committer m a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((a -> m Bool) -> Committer m a) -> (a -> m Bool) -> Committer m a
forall a b. (a -> b) -> a -> b
$ \a
a ->
      case a -> Either b c
f a
a of
        Left b
b -> Committer m b -> b -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m b
i1 b
b
        Right c
c -> Committer m c -> c -> m Bool
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 :: (b -> m (Maybe a)) -> Committer m a -> Committer m b
witherC b -> m (Maybe a)
f Committer m a
c = (b -> m Bool) -> Committer m b
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 -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just a
fb' -> Committer m a -> a -> m Bool
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 :: Committer m a -> Committer m [a]
listC Committer m a
c = ([a] -> m Bool) -> Committer m [a]
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer (([a] -> m Bool) -> Committer m [a])
-> ([a] -> m Bool) -> Committer m [a]
forall a b. (a -> b) -> a -> b
$ \[a]
as ->
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> m [Bool] -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m Bool] -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Committer m a -> a -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
c (a -> m Bool) -> [a] -> [m Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as)

-- | 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 :: Committer (StateT (Seq a) m) a
push = (a -> StateT (Seq a) m Bool) -> Committer (StateT (Seq a) m) a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((a -> StateT (Seq a) m Bool) -> Committer (StateT (Seq a) m) a)
-> (a -> StateT (Seq a) m Bool) -> Committer (StateT (Seq a) m) a
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  (Seq a -> Seq a) -> StateT (Seq a) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.:|> a
a)
  Bool -> StateT (Seq a) m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True