{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Box.Emitter
( Emitter (..),
type CoEmitter,
toListM,
witherE,
readE,
unlistE,
takeE,
takeUntilE,
dropE,
pop,
)
where
import Box.Functor
import Control.Applicative
import Control.Monad.Codensity
import Control.Monad.State.Lazy
import Data.Bool
import qualified Data.DList as D
import qualified Data.Sequence as Seq
import Data.Text (Text, pack, unpack)
import Prelude
newtype Emitter m a = Emitter
{ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit :: m (Maybe a)
}
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)
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
(<>)
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
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
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 -> m (Maybe b)
go
Just b
fa' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just b
fa')
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)
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 :: 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)
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)
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
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 :: (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)