{-# LANGUAGE ExplicitNamespaces #-}

-- | 'Emitter' wraps a producer destructor.
--
-- "Every Thought emits a Dice Throw" ~ Stéphane Mallarmé
module Box.Emitter
  ( Emitter (..),
    type CoEmitter,
    toListM,
    witherE,
    filterE,
    readE,
    unlistE,
    takeE,
    takeUntilE,
    dropE,
    pop,
  )
where

import Box.Functor
import Control.Applicative
import Control.Monad
import Control.Monad.Codensity
import Control.Monad.State.Lazy
import Data.Bool
import Data.DList qualified as D
import Data.Sequence qualified as Seq
import Data.Text (Text, pack, unpack)
import Prelude

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

-- | An `Emitter` `emit`s values of type 'Maybe' a. Source and producer are similar metaphors. An Emitter reaches into itself for the value to emit, where itself is an opaque thing from the pov of usage.
--
-- >>> e = Emitter (pure (Just "I'm emitted"))
-- >>> emit e
-- Just "I'm emitted"
--
-- >>> emit mempty
-- Nothing
newtype Emitter m a = Emitter
  { forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit :: m (Maybe a)
  }

-- | An 'Emitter' continuation.
type CoEmitter m a = Codensity m (Emitter m a)

instance FFunctor Emitter where
  foist :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Emitter f a -> Emitter g a
foist forall x. f x -> g x
nat (Emitter f (Maybe a)
e) = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (forall x. f x -> g x
nat f (Maybe a)
e)

instance (Functor m) => Functor (Emitter m) where
  fmap :: forall a b. (a -> b) -> Emitter m a -> Emitter m b
fmap a -> b
f Emitter m a
m = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
m))

instance (Applicative m) => Applicative (Emitter m) where
  pure :: forall a. a -> Emitter m a
pure a
r = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r))

  Emitter m (a -> b)
mf <*> :: forall a b. Emitter m (a -> b) -> Emitter m a -> Emitter m b
<*> Emitter m a
mx = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m (a -> b)
mf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
mx)

instance (Monad m) => Monad (Emitter m) where
  return :: forall a. a -> Emitter m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

  Emitter m a
m >>= :: forall a b. Emitter m a -> (a -> Emitter m b) -> Emitter m b
>>= a -> Emitter m b
f =
    forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
      Maybe a
ma <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
m
      case Maybe a
ma of
        Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just a
a -> forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit (a -> Emitter m b
f a
a)

instance (Monad m, Alternative m) => Alternative (Emitter m) where
  empty :: forall a. Emitter m a
empty = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)

  Emitter m a
x <|> :: forall a. Emitter m a -> Emitter m a -> Emitter m a
<|> Emitter m a
y =
    forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
      (Emitter m a
i, Maybe a
ma) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Emitter m a
y) (forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
x) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Emitter m a
x) (forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
y)
      case Maybe a
ma of
        Maybe a
Nothing -> forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
i
        Just a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
a)

  -- Zero or more.
  many :: forall a. Emitter m a -> Emitter m [a]
many Emitter m a
e = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Emitter m a -> m [a]
toListM Emitter m a
e

instance (Alternative m, Monad m) => MonadPlus (Emitter m) where
  mzero :: forall a. Emitter m a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty

  mplus :: forall a. Emitter m a -> Emitter m a -> Emitter m a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance (Alternative m, Monad m) => Semigroup (Emitter m a) where
  <> :: Emitter m a -> Emitter m a -> Emitter m a
(<>) = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance (Alternative m, Monad m) => Monoid (Emitter m a) where
  mempty :: Emitter m a
mempty = forall (f :: * -> *) a. Alternative f => f a
empty

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

-- | This fold completes on the first Nothing emitted, which may not be what you want.
instance FoldableM Emitter where
  foldrM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b -> m b) -> m b -> Emitter m a -> m b
foldrM a -> m b -> m b
acc m b
begin Emitter m a
e =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe m b
begin (\a
a' -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(FoldableM t, Monad m) =>
(a -> m b -> m b) -> m b -> t m a -> m b
foldrM a -> m b -> m b
acc (a -> m b -> m b
acc a
a' m b
begin) Emitter m a
e) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e

-- | Collect emits into a list, and close on the first Nothing.
--
-- >>> toListM <$|> qList [1..3]
-- [1,2,3]
toListM :: (Monad m) => Emitter m a -> m [a]
toListM :: forall (m :: * -> *) a. Monad m => Emitter m a -> m [a]
toListM Emitter m a
e = forall a. DList a -> [a]
D.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(FoldableM t, Monad m) =>
(a -> m b -> m b) -> m b -> t m a -> m b
foldrM (\a
a m (DList a)
acc -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. DList a -> a -> DList a
`D.snoc` a
a) m (DList a)
acc) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. DList a
D.empty) Emitter m a
e

-- | A monadic [Witherable](https://hackage.haskell.org/package/witherable)
--
-- >>> toListM <$|> witherE (\x -> bool (print x >> pure Nothing) (pure (Just x)) (even x)) <$> (qList [1..3])
-- 1
-- []
witherE :: (Monad m) => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE a -> m (Maybe b)
f Emitter m a
e = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter m (Maybe b)
go
  where
    go :: m (Maybe b)
go = do
      Maybe a
a <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
      case Maybe a
a of
        Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just a
a' -> do
          Maybe b
fa <- a -> m (Maybe b)
f a
a'
          case Maybe b
fa of
            Maybe b
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just b
fa' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just b
fa')

-- | Like witherE but does not emit Nothing on filtering.
--
-- >>> toListM <$|> filterE (\x -> bool (print x >> pure Nothing) (pure (Just x)) (even x)) <$> (qList [1..3])
-- 1
-- 3
-- [2]
filterE :: (Monad m) => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b
filterE :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
filterE a -> m (Maybe b)
f Emitter m a
e = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter m (Maybe b)
go
  where
    go :: m (Maybe b)
go = do
      Maybe a
a <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
      case Maybe a
a of
        Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just a
a' -> do
          Maybe b
fa <- a -> m (Maybe b)
f a
a'
          case Maybe b
fa of
            Maybe b
Nothing -> m (Maybe b)
go
            Just b
fa' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just b
fa')

-- | Read parse 'Emitter', returning the original text on error
--
-- >>> (toListM . readE) <$|> (qList ["1","2","3","four"]) :: IO [Either Text Int]
-- [Right 1,Right 2,Right 3,Left "four"]
readE ::
  (Functor m, Read a) =>
  Emitter m Text ->
  Emitter m (Either Text a)
readE :: forall (m :: * -> *) a.
(Functor m, Read a) =>
Emitter m Text -> Emitter m (Either Text a)
readE = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall {b}. Read b => String -> Either Text b
parsed forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
  where
    parsed :: String -> Either Text b
parsed String
str =
      case forall a. Read a => ReadS a
reads String
str of
        [(b
a, String
"")] -> forall a b. b -> Either a b
Right b
a
        [(b, String)]
_err -> forall a b. a -> Either a b
Left (String -> Text
pack String
str)

-- | Convert a list emitter to a (Stateful) element emitter.
--
-- >>> import Control.Monad.State.Lazy
-- >>> flip runStateT [] . toListM . unlistE <$|> (qList [[0..3],[5..7]])
-- ([0,1,2,3,5,6,7],[])
unlistE :: (Monad m) => Emitter m [a] -> Emitter (StateT [a] m) a
unlistE :: forall (m :: * -> *) a.
Monad m =>
Emitter m [a] -> Emitter (StateT [a] m) a
unlistE Emitter m [a]
es = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter StateT [a] m (Maybe a)
unlists
  where
    -- unlists :: (Monad m) => StateT [a] m (Maybe a)
    unlists :: StateT [a] m (Maybe a)
unlists = do
      [a]
rs <- forall s (m :: * -> *). MonadState s m => m s
get
      case [a]
rs of
        [] -> do
          Maybe [a]
xs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m [a]
es
          case Maybe [a]
xs of
            Maybe [a]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just [a]
xs' -> do
              forall s (m :: * -> *). MonadState s m => s -> m ()
put [a]
xs'
              StateT [a] m (Maybe a)
unlists
        (a
x : [a]
rs') -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put [a]
rs'
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
x)

-- | Take n emits.
--
-- >>> import Control.Monad.State.Lazy
-- >>> flip evalStateT 0 <$|> toListM . takeE 4 <$> qList [0..]
-- [0,1,2,3]
takeE :: (Monad m) => Int -> Emitter m a -> Emitter (StateT Int m) a
takeE :: forall (m :: * -> *) a.
Monad m =>
Int -> Emitter m a -> Emitter (StateT Int m) a
takeE Int
n (Emitter m (Maybe a)
e) =
  forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n' -> forall a. a -> a -> Bool -> a
bool (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
n' forall a. Num a => a -> a -> a
+ Int
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe a)
e) (Int
n' forall a. Ord a => a -> a -> Bool
< Int
n)

-- | Drop n emits.
--
-- >>> import Control.Monad.State.Lazy
-- >>> toListM <$|> (dropE 2 =<< qList [0..3])
-- [2,3]
dropE :: (Monad m) => Int -> Emitter m a -> CoEmitter m a
dropE :: forall (m :: * -> *) a.
Monad m =>
Int -> Emitter m a -> CoEmitter m a
dropE Int
n Emitter m a
e = forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall a b. (a -> b) -> a -> b
$ \Emitter m a -> m b
k -> do
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n (forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e)
  Emitter m a -> m b
k Emitter m a
e

-- | Take from an emitter until a predicate.
--
-- >>> (toListM . takeUntilE (==3)) <$|> (qList [0..])
-- [0,1,2]
takeUntilE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a
takeUntilE :: forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Emitter m a -> Emitter m a
takeUntilE a -> Bool
p Emitter m a
e = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Maybe a
x <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
  case Maybe a
x of
    Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just a
x' ->
      forall a. a -> a -> Bool -> a
bool (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
x')) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (a -> Bool
p a
x')

-- | Pop from a State sequence.
--
-- >>> import qualified Data.Sequence as Seq
-- >>> import Control.Monad.State.Lazy (evalStateT)
-- >>> flip evalStateT (Seq.fromList [1..3]) $ toListM pop
-- [1,2,3]
pop :: (Monad m) => Emitter (StateT (Seq.Seq a) m) a
pop :: forall (m :: * -> *) a. Monad m => Emitter (StateT (Seq a) m) a
pop = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Seq a
xs <- forall s (m :: * -> *). MonadState s m => m s
get
  case Seq a
xs of
    Seq a
Seq.Empty -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (a
x Seq.:<| Seq a
xs') -> do
      forall s (m :: * -> *). MonadState s m => s -> m ()
put Seq a
xs'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
x)