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

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

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 qualified Data.Sequence as Seq
import Data.String
import Data.Text as Text hiding (null)
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 = 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
<$> 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 = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \Text
a -> Text -> IO ()
Text.putStrLn Text
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | 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 = forall a. Int -> IO a -> CoEmitter IO a
source Int
n IO Text
Text.getLine

-- FIXME: This doctest sometimes fails with the last value not being printed. Hypothesis: the pipe collapses before the console print effect happens.

-- | 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 = 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 = forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(Functor m, Read a) =>
Emitter m Text -> Emitter m (Either Text a)
readE 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 = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Committer IO Text
toStdout

-- | Emits lines of Text from a handle.
-- handleEText = handleE Text.hGetLine

-- handleEBS = handleE Char8.hGetLine

-- | 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 = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Either IOException a
l :: (Either IOException a) <- forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> IO a
action Handle
h)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either IOException a
l of
    Left IOException
_ -> forall a. Maybe a
Nothing
    Right a
a -> forall a. a -> a -> Bool -> a
bool (forall a. a -> Maybe a
Just a
a) forall a. Maybe a
Nothing (a
a 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 = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \a
a -> do
  Handle -> a -> IO ()
action Handle
h a
a
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | Commit lines of Text to a handle.
-- handleCBS = handleC Char8.hPutStrLn

-- | Emits lines of Text from a handle.
-- handleCText = handleC Text.hPutStrLn

-- | Emit lines of Text 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 k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall a b. (a -> b) -> a -> b
$ \Emitter IO a -> IO b
eio ->
  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)
    )

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

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

-- | Commit lines of Text 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 k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall a b. (a -> b) -> a -> b
$ \Committer IO a -> IO b
cio ->
  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)
    )

fileCText :: FilePath -> BufferMode -> IOMode -> CoCommitter IO Text
fileCText :: String -> BufferMode -> IOMode -> CoCommitter IO Text
fileCText String
fp BufferMode
m IOMode
b = forall a.
String
-> IOMode
-> BufferMode
-> (Handle -> Committer IO a)
-> CoCommitter IO a
fileC String
fp IOMode
b BufferMode
m (forall a. (Handle -> a -> IO ()) -> Handle -> Committer IO a
handleC Handle -> Text -> IO ()
Text.hPutStrLn)

fileCBS :: FilePath -> BufferMode -> IOMode -> CoCommitter IO ByteString
fileCBS :: String -> BufferMode -> IOMode -> CoCommitter IO ByteString
fileCBS String
fp BufferMode
m IOMode
b = forall a.
String
-> IOMode
-> BufferMode
-> (Handle -> Committer IO a)
-> CoCommitter IO a
fileC String
fp IOMode
b BufferMode
m (forall a. (Handle -> a -> IO ()) -> Handle -> Committer IO a
handleC Handle -> ByteString -> IO ()
Char8.hPutStrLn)

-- | 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 <- forall a. a -> IO (IORef a)
newIORef forall a. Seq a
Seq.empty
  let c :: Committer IO a
c = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \a
a -> do
        forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Seq a)
ref (forall a. Seq a -> a -> Seq a
Seq.:|> a
a)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  let res :: IO [a]
res = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Seq a)
ref
  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 <- forall a. a -> IO (IORef a)
newIORef [a]
xs
  let e :: Emitter IO a
e = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
        [a]
as <- forall a. IORef a -> IO a
readIORef IORef [a]
ref
        case [a]
as of
          [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          (a
x : [a]
xs') -> do
            forall a. IORef a -> a -> IO ()
writeIORef IORef [a]
ref [a]
xs'
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
  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 = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Maybe a
a <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO a
e
  String -> IO ()
Prelude.putStrLn (String
label forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Maybe a
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 = forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer forall a b. (a -> b) -> a -> b
$ \a
a -> do
  String -> IO ()
Prelude.putStrLn (String
label forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
a)
  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 = forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO (Maybe a)
rec -> do
  Maybe Bool
b' <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Bool
b
  case Maybe Bool
b' of
    Maybe Bool
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just Bool
False -> 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 = forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter a
a0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Maybe a
r <- 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 IO a
e
  case Maybe a
r of
    Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just a
r' -> do
      a
r'' <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put a
r'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (a
r' 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 = 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 = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO Bool
rec -> do
  Maybe Bool
a <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Bool
True -> 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 = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO (Either Bool a)
rec -> do
  Either Bool a
res <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left Bool
False)
    Right a
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right a
r)