{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

-- | `emit`
module Box.Emitter
  ( Emitter (..),
    type CoEmitter,
    toListM,
    witherE,
    readE,
    unlistE,
    takeE,
    takeUntilE,
    pop,
)
where

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

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

-- | an `Emitter` `emit`s values of type Maybe a. Source & Producer are also appropriate 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
  { 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 x. f x -> g x) -> Emitter f a -> Emitter g a
foist forall x. f x -> g x
nat (Emitter f (Maybe a)
e) = g (Maybe a) -> Emitter g a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (f (Maybe a) -> g (Maybe a)
forall x. f x -> g x
nat f (Maybe a)
e)

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

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

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

instance (Monad m) => Monad (Emitter m) where
  return :: a -> Emitter m a
return a
r = m (Maybe a) -> Emitter m a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r))

  Emitter m a
m >>= :: Emitter m a -> (a -> Emitter m b) -> Emitter m b
>>= a -> Emitter m b
f =
    m (Maybe b) -> Emitter m b
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (m (Maybe b) -> Emitter m b) -> m (Maybe b) -> Emitter m b
forall a b. (a -> b) -> a -> b
$ do
      Maybe a
ma <- Emitter m a -> m (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
m
      case Maybe a
ma of
        Maybe a
Nothing -> Maybe b -> m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
        Just a
a -> Emitter m b -> m (Maybe b)
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 :: Emitter m a
empty = m (Maybe a) -> Emitter m a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

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

  -- | Zero or more.
  many :: Emitter m a -> Emitter m [a]
many Emitter m a
e = m (Maybe [a]) -> Emitter m [a]
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (m (Maybe [a]) -> Emitter m [a]) -> m (Maybe [a]) -> Emitter m [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> Maybe [a]) -> m [a] -> m (Maybe [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emitter m a -> m [a]
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 :: Emitter m a
mzero = Emitter m a
forall (f :: * -> *) a. Alternative f => f a
empty

  mplus :: Emitter m a -> Emitter m a -> Emitter m a
mplus = 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) => Semigroup (Emitter m a) where
  <> :: Emitter m a -> Emitter m a -> Emitter m a
(<>) = 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 = Emitter m a
forall (f :: * -> *) a. Alternative f => f a
empty

  mappend :: Emitter m a -> Emitter m a -> Emitter m a
mappend = Emitter m a -> Emitter m a -> Emitter m a
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 :: (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 =
    m b -> (a -> m b) -> Maybe a -> m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m b
begin (\a
a' -> (a -> m b -> m b) -> m b -> Emitter m a -> m b
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) (Maybe a -> m b) -> m (Maybe a) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Emitter m a -> m (Maybe a)
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 :: Emitter m a -> m [a]
toListM Emitter m a
e = DList a -> [a]
forall a. DList a -> [a]
D.toList (DList a -> [a]) -> m (DList a) -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m (DList a) -> m (DList a))
-> m (DList a) -> Emitter m a -> m (DList a)
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 -> (DList a -> DList a) -> m (DList a) -> m (DList a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DList a -> a -> DList a
forall a. DList a -> a -> DList a
`D.snoc` a
a) m (DList a)
acc) (DList a -> m (DList a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DList a
forall a. DList a
D.empty) Emitter m a
e

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

-- | Read parse 'Emitter', returning the original text on error
--
-- >>> process (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 :: Emitter m Text -> Emitter m (Either Text a)
readE = (Text -> Either Text a)
-> Emitter m Text -> Emitter m (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Either Text a)
 -> Emitter m Text -> Emitter m (Either Text a))
-> (Text -> Either Text a)
-> Emitter m Text
-> Emitter m (Either Text a)
forall a b. (a -> b) -> a -> b
$ String -> Either Text a
forall b. Read b => String -> Either Text b
parsed (String -> Either Text a)
-> (Text -> String) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
  where
    parsed :: String -> Either Text b
parsed String
str =
      case ReadS b
forall a. Read a => ReadS a
reads String
str of
        [(b
a, String
"")] -> b -> Either Text b
forall a b. b -> Either a b
Right b
a
        [(b, String)]
_err -> Text -> Either Text b
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
-- >>> close $ 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 :: Emitter m [a] -> Emitter (StateT [a] m) a
unlistE Emitter m [a]
es = StateT [a] m (Maybe a) -> Emitter (StateT [a] m) a
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 <- StateT [a] m [a]
forall s (m :: * -> *). MonadState s m => m s
get
    case [a]
rs of
      [] -> do
        Maybe [a]
xs <- m (Maybe [a]) -> StateT [a] m (Maybe [a])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe [a]) -> StateT [a] m (Maybe [a]))
-> m (Maybe [a]) -> StateT [a] m (Maybe [a])
forall a b. (a -> b) -> a -> b
$ Emitter m [a] -> m (Maybe [a])
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m [a]
es
        case Maybe [a]
xs of
          Maybe [a]
Nothing -> Maybe a -> StateT [a] m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
          Just [a]
xs' -> do
            [a] -> StateT [a] m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [a]
xs'
            StateT [a] m (Maybe a)
unlists
      (a
x:[a]
rs') -> do
        [a] -> StateT [a] m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [a]
rs'
        Maybe a -> StateT [a] m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x)

-- | Take n emits.
--
-- >>> import Control.Monad.State.Lazy
-- >>> close $ 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 :: Int -> Emitter m a -> Emitter (StateT Int m) a
takeE Int
n (Emitter m (Maybe a)
e) =
  StateT Int m (Maybe a) -> Emitter (StateT Int m) a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (StateT Int m (Maybe a) -> Emitter (StateT Int m) a)
-> StateT Int m (Maybe a) -> Emitter (StateT Int m) a
forall a b. (a -> b) -> a -> b
$ StateT Int m Int
forall s (m :: * -> *). MonadState s m => m s
get StateT Int m Int
-> (Int -> StateT Int m (Maybe a)) -> StateT Int m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n' -> StateT Int m (Maybe a)
-> StateT Int m (Maybe a) -> Bool -> StateT Int m (Maybe a)
forall a. a -> a -> Bool -> a
bool (Maybe a -> StateT Int m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing) (Int -> StateT Int m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
n'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) StateT Int m () -> StateT Int m (Maybe a) -> StateT Int m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (Maybe a) -> StateT Int m (Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe a)
e) (Int
n'Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n)

-- | Take from an emitter until a predicate.
--
-- >>> process (toListM . takeUntilE (==3)) (qList [0..])
-- [0,1,2]
takeUntilE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a
takeUntilE :: (a -> Bool) -> Emitter m a -> Emitter m a
takeUntilE a -> Bool
p Emitter m a
e = m (Maybe a) -> Emitter m a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (m (Maybe a) -> Emitter m a) -> m (Maybe a) -> Emitter m a
forall a b. (a -> b) -> a -> b
$ do
  Maybe a
x <- Emitter m a -> m (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
  case Maybe a
x of
    Maybe a
Nothing -> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just a
x' ->
      m (Maybe a) -> m (Maybe a) -> Bool -> m (Maybe a)
forall a. a -> a -> Bool -> a
bool (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x')) (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
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 :: Emitter (StateT (Seq a) m) a
pop = StateT (Seq a) m (Maybe a) -> Emitter (StateT (Seq a) m) a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (StateT (Seq a) m (Maybe a) -> Emitter (StateT (Seq a) m) a)
-> StateT (Seq a) m (Maybe a) -> Emitter (StateT (Seq a) m) a
forall a b. (a -> b) -> a -> b
$ do
  Seq a
xs <- StateT (Seq a) m (Seq a)
forall s (m :: * -> *). MonadState s m => m s
get
  case Seq a
xs of
    Seq a
Seq.Empty -> Maybe a -> StateT (Seq a) m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    (a
x Seq.:<| Seq a
xs') -> do
      Seq a -> StateT (Seq a) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Seq a
xs'
      Maybe a -> StateT (Seq a) m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x)