{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Box.Emitter
( Emitter (..),
mapE,
readE,
readE_,
parseE,
parseE_,
premapE,
postmapE,
postmapM,
toListE,
unlistE,
stateE,
takeE,
takeUntilE,
filterE,
)
where
import qualified Data.Attoparsec.Text as A
import NumHask.Prelude
newtype Emitter m a
= Emitter
{ emit :: m (Maybe a)
}
instance MFunctor Emitter where
hoist nat (Emitter e) = Emitter (nat e)
instance (Functor m) => Functor (Emitter m) where
fmap f m = Emitter (fmap (fmap f) (emit m))
instance (Applicative m) => Applicative (Emitter m) where
pure r = Emitter (pure (pure r))
mf <*> mx = Emitter ((<*>) <$> emit mf <*> emit mx)
instance (Monad m) => Monad (Emitter m) where
return r = Emitter (return (return r))
m >>= f =
Emitter $ do
ma <- emit m
case ma of
Nothing -> return Nothing
Just a -> emit (f a)
instance (Monad m, Alternative m) => Alternative (Emitter m) where
empty = Emitter (pure Nothing)
x <|> y =
Emitter $ do
(i, ma) <- fmap ((,) y) (emit x) <|> fmap ((,) x) (emit y)
case ma of
Nothing -> emit i
Just a -> pure (Just a)
instance (Alternative m, Monad m) => MonadPlus (Emitter m) where
mzero = empty
mplus = (<|>)
instance (Alternative m, Monad m) => Semigroup (Emitter m a) where
(<>) = (<|>)
instance (Alternative m, Monad m) => Monoid (Emitter m a) where
mempty = empty
mappend = (<>)
mapE :: (Monad m) => (a -> m (Maybe b)) -> Emitter m a -> Emitter m b
mapE f e = Emitter go
where
go = do
a <- emit e
case a of
Nothing -> pure Nothing
Just a' -> do
fa <- f a'
case fa of
Nothing -> go
Just fa' -> pure (Just fa')
parseE :: (Functor m) => A.Parser a -> Emitter m Text -> Emitter m (Either Text a)
parseE parser e = (\t -> either (const $ Left t) Right (A.parseOnly parser t)) <$> e
parseE_ :: (Monad m) => A.Parser a -> Emitter m Text -> Emitter m a
parseE_ parser = mapE (pure . (either (const Nothing) Just)) . parseE parser
readE ::
(Functor m, Read a) =>
Emitter m Text ->
Emitter m (Either Text a)
readE = fmap $ parsed . unpack
where
parsed str =
case reads str of
[(a, "")] -> Right a
_ -> Left (pack str)
readE_ ::
(Monad m, Read a) =>
Emitter m Text ->
Emitter m a
readE_ = mapE (pure . (either (const Nothing) Just)) . readE
premapE ::
(Applicative m) =>
(Emitter m a -> m ()) ->
Emitter m a ->
Emitter m a
premapE f e = Emitter $ f e *> emit e
postmapE ::
(Monad m) =>
(Emitter m a -> m ()) ->
Emitter m a ->
Emitter m a
postmapE f e = Emitter $ do
r <- emit e
f e
pure r
postmapM ::
(Monad m) =>
(a -> m ()) ->
Emitter m a ->
Emitter m a
postmapM f e = Emitter $ do
r <- emit e
case r of
Nothing -> pure Nothing
Just r' -> do
f r'
pure (Just r')
toListE :: (Monad m) => Emitter m a -> m [a]
toListE e = go [] e
where
go xs e' = do
x <- emit e'
case x of
Nothing -> pure (reverse xs)
Just x' -> go (x' : xs) e'
stateE :: (Monad m) => Emitter (StateT [a] m) a
stateE = Emitter $ do
xs' <- get
case xs' of
[] -> pure Nothing
(x : xs'') -> do
put xs''
pure $ Just x
unlistE :: (Monad m) => Emitter m [a] -> Emitter (StateT [a] m) a
unlistE es = mapE unlistS (hoist lift es)
where
unlistS xs = do
rs <- get
case rs <> xs of
[] -> pure Nothing
(x : xs') -> do
put xs'
pure (Just x)
takeE :: (Monad m) => Int -> Emitter m a -> Emitter (StateT Int m) a
takeE n e = Emitter $ do
x <- emit (hoist lift e)
case x of
Nothing -> pure Nothing
Just x' -> do
n' <- get
bool (pure Nothing) (emit' n') (n' < n)
where
emit' n' = do
put (n'+1)
pure $ Just x'
takeUntilE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a
takeUntilE p e = Emitter $ do
x <- emit e
case x of
Nothing -> pure Nothing
Just x' ->
bool (pure (Just x')) (pure Nothing) (p x')
filterE :: (Monad m) => (a -> Bool) -> Emitter m a -> Emitter m a
filterE p e = Emitter go
where
go = do
x <- emit e
case x of
Nothing -> pure Nothing
Just x' ->
bool go (pure (Just x')) (p x')