{-# LANGUAGE OverloadedStrings #-}

-- | IO effects
module Box.IO
  ( fromStdin,
    toStdout,
    stdBox,
    fromStdinN,
    toStdoutN,
    readStdin,
    showStdout,
    refCommitter,
    refEmitter,
    handleE,
    handleC,
    fileE,
    fileC,
    fileEText,
    fileEBS,
    fileCText,
    fileCBS,
    toLineBox,
    fromLineBox,
    logConsoleC,
    logConsoleE,
    pauser,
    changer,
    quit,
    restart,
  )
where

import Box.Box
import Box.Codensity
import Box.Committer
import Box.Connectors
import Box.Emitter
import Control.Concurrent.Async
import Control.Exception
import Control.Monad.State.Lazy
import Data.Bool
import Data.ByteString.Char8 as Char8
import Data.Foldable
import Data.Function
import Data.Functor.Contravariant
import Data.IORef
import Data.Sequence qualified as Seq
import Data.String
import Data.Text as Text hiding (null)
import Data.Text.Encoding
import Data.Text.IO as Text
import System.IO as IO
import Prelude

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

-- * console

-- | Emit text from stdin
--
-- @
-- λ> emit fromStdin
-- hello
-- Just "hello"
-- @
fromStdin :: Emitter IO Text
fromStdin :: Emitter IO Text
fromStdin = IO (Maybe Text) -> Emitter IO Text
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (IO (Maybe Text) -> Emitter IO Text)
-> IO (Maybe Text) -> Emitter IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
Text.getLine

-- | Commit to stdout
--
-- >>> commit toStdout ("I'm committed!" :: Text)
-- I'm committed!
-- True
toStdout :: Committer IO Text
toStdout :: Committer IO Text
toStdout = (Text -> IO Bool) -> Committer IO Text
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((Text -> IO Bool) -> Committer IO Text)
-> (Text -> IO Bool) -> Committer IO Text
forall a b. (a -> b) -> a -> b
$ \Text
a -> Text -> IO ()
Text.putStrLn Text
a IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | A 'Box' to and from std, with an escape phrase.
stdBox :: Text -> Box IO Text Text
stdBox :: Text -> Box IO Text Text
stdBox Text
q = Committer IO Text -> Emitter IO Text -> Box IO Text Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer IO Text
toStdout ((Text -> Bool) -> Emitter IO Text -> Emitter IO Text
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Emitter m a -> Emitter m a
takeUntilE (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
q) Emitter IO Text
fromStdin)

-- | Finite console emitter
--
-- @
-- λ> toListM /<$|/> fromStdinN 2
-- hello
-- hello again
-- ["hello","hello again"]
-- @
fromStdinN :: Int -> CoEmitter IO Text
fromStdinN :: Int -> CoEmitter IO Text
fromStdinN Int
n = Int -> IO Text -> CoEmitter IO Text
forall a. Int -> IO a -> CoEmitter IO a
source Int
n IO Text
Text.getLine

-- | Finite console committer
--
-- >>> glue <$> contramap (pack . show) <$> (toStdoutN 2) <*|> qList [1..3]
-- 1
-- 2
toStdoutN :: Int -> CoCommitter IO Text
toStdoutN :: Int -> CoCommitter IO Text
toStdoutN Int
n = Int -> (Text -> IO ()) -> CoCommitter IO Text
forall a. Int -> (a -> IO ()) -> CoCommitter IO a
sink Int
n Text -> IO ()
Text.putStrLn

-- | Read from console, throwing away read errors
--
-- > λ> glueN 2 showStdout (readStdin :: Emitter IO Int)
-- > 1
-- > 1
-- > hippo
-- > 2
-- > 2
readStdin :: (Read a) => Emitter IO a
readStdin :: forall a. Read a => Emitter IO a
readStdin = (Either Text a -> IO (Maybe a))
-> Emitter IO (Either Text a) -> Emitter IO a
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE (Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a))
-> (Either Text a -> Maybe a) -> Either Text a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe a) -> (a -> Maybe a) -> Either Text a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> Text -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just) (Emitter IO (Either Text a) -> Emitter IO a)
-> (Emitter IO Text -> Emitter IO (Either Text a))
-> Emitter IO Text
-> Emitter IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Emitter IO Text -> Emitter IO (Either Text a)
forall (m :: * -> *) a.
(Functor m, Read a) =>
Emitter m Text -> Emitter m (Either Text a)
readE (Emitter IO Text -> Emitter IO a)
-> Emitter IO Text -> Emitter IO a
forall a b. (a -> b) -> a -> b
$ Emitter IO Text
fromStdin

-- | Show to stdout
--
-- >>> glue showStdout <$|> qList [1..3]
-- 1
-- 2
-- 3
showStdout :: (Show a) => Committer IO a
showStdout :: forall a. Show a => Committer IO a
showStdout = (a -> Text) -> Committer IO Text -> Committer IO a
forall a' a. (a' -> a) -> Committer IO a -> Committer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) Committer IO Text
toStdout

-- | Emits lines of Text from a handle.
handleE :: (IsString a, Eq a) => (Handle -> IO a) -> Handle -> Emitter IO a
handleE :: forall a.
(IsString a, Eq a) =>
(Handle -> IO a) -> Handle -> Emitter IO a
handleE Handle -> IO a
action Handle
h = IO (Maybe a) -> Emitter IO a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (IO (Maybe a) -> Emitter IO a) -> IO (Maybe a) -> Emitter IO a
forall a b. (a -> b) -> a -> b
$ do
  Either IOException a
l :: (Either IOException a) <- IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> IO a
action Handle
h)
  Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ case Either IOException a
l of
    Left IOException
_ -> Maybe a
forall a. Maybe a
Nothing
    Right a
a -> Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool (a -> Maybe a
forall a. a -> Maybe a
Just a
a) Maybe a
forall a. Maybe a
Nothing (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"")

-- | Commit lines of Text to a handle.
handleC :: (Handle -> a -> IO ()) -> Handle -> Committer IO a
handleC :: forall a. (Handle -> a -> IO ()) -> Handle -> Committer IO a
handleC Handle -> a -> IO ()
action Handle
h = (a -> IO Bool) -> Committer IO a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((a -> IO Bool) -> Committer IO a)
-> (a -> IO Bool) -> Committer IO a
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  Handle -> a -> IO ()
action Handle
h a
a
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | Emit from a file.
fileE :: FilePath -> BufferMode -> IOMode -> (Handle -> Emitter IO a) -> CoEmitter IO a
fileE :: forall a.
String
-> BufferMode
-> IOMode
-> (Handle -> Emitter IO a)
-> CoEmitter IO a
fileE String
fp BufferMode
b IOMode
m Handle -> Emitter IO a
action = (forall b. (Emitter IO a -> IO b) -> IO b)
-> Codensity IO (Emitter IO a)
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Emitter IO a -> IO b) -> IO b)
 -> Codensity IO (Emitter IO a))
-> (forall b. (Emitter IO a -> IO b) -> IO b)
-> Codensity IO (Emitter IO a)
forall a b. (a -> b) -> a -> b
$ \Emitter IO a -> IO b
eio ->
  String -> IOMode -> (Handle -> IO b) -> IO b
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile
    String
fp
    IOMode
m
    ( \Handle
h -> do
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
b
        Emitter IO a -> IO b
eio (Handle -> Emitter IO a
action Handle
h)
    )

-- | Emit lines of Text from a file.
fileEText :: FilePath -> BufferMode -> CoEmitter IO Text
fileEText :: String -> BufferMode -> CoEmitter IO Text
fileEText String
fp BufferMode
b = String
-> BufferMode
-> IOMode
-> (Handle -> Emitter IO Text)
-> CoEmitter IO Text
forall a.
String
-> BufferMode
-> IOMode
-> (Handle -> Emitter IO a)
-> CoEmitter IO a
fileE String
fp BufferMode
b IOMode
ReadMode ((Handle -> IO Text) -> Handle -> Emitter IO Text
forall a.
(IsString a, Eq a) =>
(Handle -> IO a) -> Handle -> Emitter IO a
handleE Handle -> IO Text
Text.hGetLine)

-- | Emit lines of ByteString from a file.
fileEBS :: FilePath -> BufferMode -> CoEmitter IO ByteString
fileEBS :: String -> BufferMode -> CoEmitter IO ByteString
fileEBS String
fp BufferMode
b = String
-> BufferMode
-> IOMode
-> (Handle -> Emitter IO ByteString)
-> CoEmitter IO ByteString
forall a.
String
-> BufferMode
-> IOMode
-> (Handle -> Emitter IO a)
-> CoEmitter IO a
fileE String
fp BufferMode
b IOMode
ReadMode ((Handle -> IO ByteString) -> Handle -> Emitter IO ByteString
forall a.
(IsString a, Eq a) =>
(Handle -> IO a) -> Handle -> Emitter IO a
handleE Handle -> IO ByteString
Char8.hGetLine)

-- | Commit to a file.
fileC :: FilePath -> IOMode -> BufferMode -> (Handle -> Committer IO a) -> CoCommitter IO a
fileC :: forall a.
String
-> IOMode
-> BufferMode
-> (Handle -> Committer IO a)
-> CoCommitter IO a
fileC String
fp IOMode
m BufferMode
b Handle -> Committer IO a
action = (forall b. (Committer IO a -> IO b) -> IO b)
-> Codensity IO (Committer IO a)
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Committer IO a -> IO b) -> IO b)
 -> Codensity IO (Committer IO a))
-> (forall b. (Committer IO a -> IO b) -> IO b)
-> Codensity IO (Committer IO a)
forall a b. (a -> b) -> a -> b
$ \Committer IO a -> IO b
cio ->
  String -> IOMode -> (Handle -> IO b) -> IO b
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile
    String
fp
    IOMode
m
    ( \Handle
h -> do
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
b
        Committer IO a -> IO b
cio (Handle -> Committer IO a
action Handle
h)
    )

-- | Commit Text to a file, as a line.
fileCText :: FilePath -> BufferMode -> IOMode -> CoCommitter IO Text
fileCText :: String -> BufferMode -> IOMode -> CoCommitter IO Text
fileCText String
fp BufferMode
m IOMode
b = String
-> IOMode
-> BufferMode
-> (Handle -> Committer IO Text)
-> CoCommitter IO Text
forall a.
String
-> IOMode
-> BufferMode
-> (Handle -> Committer IO a)
-> CoCommitter IO a
fileC String
fp IOMode
b BufferMode
m ((Handle -> Text -> IO ()) -> Handle -> Committer IO Text
forall a. (Handle -> a -> IO ()) -> Handle -> Committer IO a
handleC Handle -> Text -> IO ()
Text.hPutStrLn)

-- | Commit ByteString to a file, as a line.
fileCBS :: FilePath -> BufferMode -> IOMode -> CoCommitter IO ByteString
fileCBS :: String -> BufferMode -> IOMode -> CoCommitter IO ByteString
fileCBS String
fp BufferMode
m IOMode
b = String
-> IOMode
-> BufferMode
-> (Handle -> Committer IO ByteString)
-> CoCommitter IO ByteString
forall a.
String
-> IOMode
-> BufferMode
-> (Handle -> Committer IO a)
-> CoCommitter IO a
fileC String
fp IOMode
b BufferMode
m ((Handle -> ByteString -> IO ())
-> Handle -> Committer IO ByteString
forall a. (Handle -> a -> IO ()) -> Handle -> Committer IO a
handleC Handle -> ByteString -> IO ()
Char8.hPutStrLn)

-- | Convert a 'Box' from ByteString to lines of Text.
toLineBox :: Text -> Box IO ByteString ByteString -> CoBox IO Text Text
toLineBox :: Text -> Box IO ByteString ByteString -> CoBox IO Text Text
toLineBox Text
end (Box Committer IO ByteString
c Emitter IO ByteString
e) = Committer IO Text -> Emitter IO Text -> Box IO Text Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((Text -> ByteString)
-> Committer IO ByteString -> Committer IO Text
forall a' a. (a' -> a) -> Committer IO a -> Committer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end)) Committer IO ByteString
c) (Emitter IO Text -> Box IO Text Text)
-> CoEmitter IO Text -> CoBox IO Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Emitter (StateT [Text] IO) Text -> CoEmitter IO Text
forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter [] (Emitter IO [Text] -> Emitter (StateT [Text] IO) Text
forall (m :: * -> *) a.
Monad m =>
Emitter m [a] -> Emitter (StateT [a] m) a
unlistE (Emitter IO [Text] -> Emitter (StateT [Text] IO) Text)
-> Emitter IO [Text] -> Emitter (StateT [Text] IO) Text
forall a b. (a -> b) -> a -> b
$ (ByteString -> [Text])
-> Emitter IO ByteString -> Emitter IO [Text]
forall a b. (a -> b) -> Emitter IO a -> Emitter IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text]
Text.lines (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8) Emitter IO ByteString
e)

-- | Convert a 'Box' from lines of Text to ByteStrings.
fromLineBox :: Text -> Box IO Text Text -> Box IO ByteString ByteString
fromLineBox :: Text -> Box IO Text Text -> Box IO ByteString ByteString
fromLineBox Text
end (Box Committer IO Text
c Emitter IO Text
e) = Committer IO ByteString
-> Emitter IO ByteString -> Box IO ByteString ByteString
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((ByteString -> [Text])
-> Committer IO [Text] -> Committer IO ByteString
forall a' a. (a' -> a) -> Committer IO a -> Committer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text -> [Text]
Text.lines (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8) (Committer IO Text -> Committer IO [Text]
forall (m :: * -> *) a. Monad m => Committer m a -> Committer m [a]
listC Committer IO Text
c)) ((Text -> ByteString) -> Emitter IO Text -> Emitter IO ByteString
forall a b. (a -> b) -> Emitter IO a -> Emitter IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end)) Emitter IO Text
e)

-- | Commit to an IORef
--
-- >>> (c1,l1) <- refCommitter :: IO (Committer IO Int, IO [Int])
-- >>> glue c1 <$|> qList [1..3]
-- >>> l1
-- [1,2,3]
refCommitter :: IO (Committer IO a, IO [a])
refCommitter :: forall a. IO (Committer IO a, IO [a])
refCommitter = do
  IORef (Seq a)
ref <- Seq a -> IO (IORef (Seq a))
forall a. a -> IO (IORef a)
newIORef Seq a
forall a. Seq a
Seq.empty
  let c :: Committer IO a
c = (a -> IO Bool) -> Committer IO a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((a -> IO Bool) -> Committer IO a)
-> (a -> IO Bool) -> Committer IO a
forall a b. (a -> b) -> a -> b
$ \a
a -> do
        IORef (Seq a) -> (Seq a -> Seq a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Seq a)
ref (Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.:|> a
a)
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  let res :: IO [a]
res = Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq a -> [a]) -> IO (Seq a) -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Seq a) -> IO (Seq a)
forall a. IORef a -> IO a
readIORef IORef (Seq a)
ref
  (Committer IO a, IO [a]) -> IO (Committer IO a, IO [a])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Committer IO a
c, IO [a]
res)

-- | Emit from a list IORef
--
-- >>> e <- refEmitter [1..3]
-- >>> toListM e
-- [1,2,3]
refEmitter :: [a] -> IO (Emitter IO a)
refEmitter :: forall a. [a] -> IO (Emitter IO a)
refEmitter [a]
xs = do
  IORef [a]
ref <- [a] -> IO (IORef [a])
forall a. a -> IO (IORef a)
newIORef [a]
xs
  let e :: Emitter IO a
e = IO (Maybe a) -> Emitter IO a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (IO (Maybe a) -> Emitter IO a) -> IO (Maybe a) -> Emitter IO a
forall a b. (a -> b) -> a -> b
$ do
        [a]
as <- IORef [a] -> IO [a]
forall a. IORef a -> IO a
readIORef IORef [a]
ref
        case [a]
as of
          [] -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
          (a
x : [a]
xs') -> do
            IORef [a] -> [a] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [a]
ref [a]
xs'
            Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
  Emitter IO a -> IO (Emitter IO a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Emitter IO a
e

-- | simple console logger for rough testing
logConsoleE :: (Show a) => String -> Emitter IO a -> Emitter IO a
logConsoleE :: forall a. Show a => String -> Emitter IO a -> Emitter IO a
logConsoleE String
label Emitter IO a
e = IO (Maybe a) -> Emitter IO a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (IO (Maybe a) -> Emitter IO a) -> IO (Maybe a) -> Emitter IO a
forall a b. (a -> b) -> a -> b
$ do
  Maybe a
a <- Emitter IO a -> IO (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO a
e
  String -> IO ()
Prelude.putStrLn (String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe a -> String
forall a. Show a => a -> String
show Maybe a
a)
  Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
a

-- | simple console logger for rough testing
logConsoleC :: (Show a) => String -> Committer IO a -> Committer IO a
logConsoleC :: forall a. Show a => String -> Committer IO a -> Committer IO a
logConsoleC String
label Committer IO a
c = (a -> IO Bool) -> Committer IO a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((a -> IO Bool) -> Committer IO a)
-> (a -> IO Bool) -> Committer IO a
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  String -> IO ()
Prelude.putStrLn (String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
a)
  Committer IO a -> a -> IO Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO a
c a
a

-- | Pause an emitter based on a Bool emitter
pauser :: Emitter IO Bool -> Emitter IO a -> Emitter IO a
pauser :: forall a. Emitter IO Bool -> Emitter IO a -> Emitter IO a
pauser Emitter IO Bool
b Emitter IO a
e = IO (Maybe a) -> Emitter IO a
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (IO (Maybe a) -> Emitter IO a) -> IO (Maybe a) -> Emitter IO a
forall a b. (a -> b) -> a -> b
$ (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a)
forall a. (a -> a) -> a
fix ((IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a))
-> (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \IO (Maybe a)
rec -> do
  Maybe Bool
b' <- Emitter IO Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Bool
b
  case Maybe Bool
b' of
    Maybe Bool
Nothing -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just Bool
False -> Emitter IO a -> IO (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO a
e
    Just Bool
True -> IO (Maybe a)
rec

-- | Create an emitter that indicates when another emitter has changed.
changer :: (Eq a) => a -> Emitter IO a -> CoEmitter IO Bool
changer :: forall a. Eq a => a -> Emitter IO a -> CoEmitter IO Bool
changer a
a0 Emitter IO a
e = a -> Emitter (StateT a IO) Bool -> CoEmitter IO Bool
forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter a
a0 (Emitter (StateT a IO) Bool -> CoEmitter IO Bool)
-> Emitter (StateT a IO) Bool -> CoEmitter IO Bool
forall a b. (a -> b) -> a -> b
$ StateT a IO (Maybe Bool) -> Emitter (StateT a IO) Bool
forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter (StateT a IO (Maybe Bool) -> Emitter (StateT a IO) Bool)
-> StateT a IO (Maybe Bool) -> Emitter (StateT a IO) Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe a
r <- IO (Maybe a) -> StateT a IO (Maybe a)
forall (m :: * -> *) a. Monad m => m a -> StateT a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe a) -> StateT a IO (Maybe a))
-> IO (Maybe a) -> StateT a IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Emitter IO a -> IO (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO a
e
  case Maybe a
r of
    Maybe a
Nothing -> Maybe Bool -> StateT a IO (Maybe Bool)
forall a. a -> StateT a IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
forall a. Maybe a
Nothing
    Just a
r' -> do
      a
r'' <- StateT a IO a
forall s (m :: * -> *). MonadState s m => m s
get
      a -> StateT a IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put a
r'
      Maybe Bool -> StateT a IO (Maybe Bool)
forall a. a -> StateT a IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (a
r' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r''))

-- | quit a process based on a Bool emitter
--
-- > quit <$> speedEffect (pure 2) <$> (resetGap 5) <*|> pure io
-- > 0
-- > 1
-- > 2
-- > 3
-- > 4
-- > Left True
quit :: Emitter IO Bool -> IO a -> IO (Either Bool a)
quit :: forall a. Emitter IO Bool -> IO a -> IO (Either Bool a)
quit Emitter IO Bool
flag IO a
io = IO Bool -> IO a -> IO (Either Bool a)
forall a b. IO a -> IO b -> IO (Either a b)
race (Emitter IO Bool -> IO Bool
checkE Emitter IO Bool
flag) IO a
io

checkE :: Emitter IO Bool -> IO Bool
checkE :: Emitter IO Bool -> IO Bool
checkE Emitter IO Bool
e = (IO Bool -> IO Bool) -> IO Bool
forall a. (a -> a) -> a
fix ((IO Bool -> IO Bool) -> IO Bool)
-> (IO Bool -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \IO Bool
rec -> do
  Maybe Bool
a <- Emitter IO Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Bool
e
  -- atomically $ check (a == Just False)
  case Maybe Bool
a of
    Maybe Bool
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Bool
True -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just Bool
False -> IO Bool
rec

-- | restart a process if flagged by a Bool emitter
restart :: Emitter IO Bool -> IO a -> IO (Either Bool a)
restart :: forall a. Emitter IO Bool -> IO a -> IO (Either Bool a)
restart Emitter IO Bool
flag IO a
io = (IO (Either Bool a) -> IO (Either Bool a)) -> IO (Either Bool a)
forall a. (a -> a) -> a
fix ((IO (Either Bool a) -> IO (Either Bool a)) -> IO (Either Bool a))
-> (IO (Either Bool a) -> IO (Either Bool a)) -> IO (Either Bool a)
forall a b. (a -> b) -> a -> b
$ \IO (Either Bool a)
rec -> do
  Either Bool a
res <- Emitter IO Bool -> IO a -> IO (Either Bool a)
forall a. Emitter IO Bool -> IO a -> IO (Either Bool a)
quit Emitter IO Bool
flag IO a
io
  case Either Bool a
res of
    Left Bool
True -> IO (Either Bool a)
rec
    Left Bool
False -> Either Bool a -> IO (Either Bool a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either Bool a
forall a b. a -> Either a b
Left Bool
False)
    Right a
r -> Either Bool a -> IO (Either Bool a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Bool a
forall a b. b -> Either a b
Right a
r)