{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Box.IO
( fromStdin,
toStdout,
fromStdinN,
toStdoutN,
readStdin,
showStdout,
handleE,
handleC,
cRef,
eRef,
fileE,
fileWriteC,
fileAppendC,
)
where
import Box.Committer
import Box.Connectors
import Box.Cont
import Box.Emitter
import qualified Control.Concurrent.Classy.IORef as C
import Control.Lens hiding ((.>), (:>), (<|), (|>))
import qualified Control.Monad.Conc.Class as C
import qualified Data.Sequence as Seq
import Data.Text.IO (hGetLine)
import NumHask.Prelude hiding (STM)
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
NumHask.Prelude.getLine
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 ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn Text
a IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
fromStdinN :: Int -> Cont IO (Emitter IO Text)
fromStdinN :: Int -> Cont IO (Emitter IO Text)
fromStdinN Int
n = Int -> IO Text -> Cont IO (Emitter IO Text)
forall (m :: * -> *) a.
MonadConc m =>
Int -> m a -> Cont m (Emitter m a)
source Int
n IO Text
NumHask.Prelude.getLine
toStdoutN :: Int -> Cont IO (Committer IO Text)
toStdoutN :: Int -> Cont IO (Committer IO Text)
toStdoutN Int
n = Int -> (Text -> IO ()) -> Cont IO (Committer IO Text)
forall (m :: * -> *) a.
MonadConc m =>
Int -> (a -> m ()) -> Cont m (Committer m a)
sink Int
n Text -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn
readStdin :: Read a => Emitter IO a
readStdin :: 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
mapE (Maybe a -> IO (Maybe 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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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
showStdout :: Show a => Committer IO a
showStdout :: Committer IO a
showStdout = (a -> Text) -> Committer IO Text -> Committer IO a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Committer IO Text
toStdout
handleE :: Handle -> Emitter IO Text
handleE :: Handle -> Emitter IO Text
handleE Handle
h = 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
$ do
Either IOException Text
l :: (Either IOException Text) <- IO Text -> IO (Either IOException Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> IO Text
hGetLine Handle
h)
Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ case Either IOException Text
l of
Left IOException
_ -> Maybe Text
forall a. Maybe a
Nothing
Right Text
a -> Maybe Text -> Maybe Text -> Bool -> Maybe Text
forall a. a -> a -> Bool -> a
bool (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
a) Maybe Text
forall a. Maybe a
Nothing (Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"")
handleC :: Handle -> Committer IO Text
handleC :: Handle -> Committer IO Text
handleC Handle
h = (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 -> do
Handle -> Text -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
hPutStrLn Handle
h Text
a
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
fileE :: FilePath -> Cont IO (Emitter IO Text)
fileE :: String -> Cont IO (Emitter IO Text)
fileE String
fp = (forall r. (Emitter IO Text -> IO r) -> IO r)
-> Cont IO (Emitter IO Text)
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont ((forall r. (Emitter IO Text -> IO r) -> IO r)
-> Cont IO (Emitter IO Text))
-> (forall r. (Emitter IO Text -> IO r) -> IO r)
-> Cont IO (Emitter IO Text)
forall a b. (a -> b) -> a -> b
$ \Emitter IO Text -> IO r
eio -> String -> IOMode -> (Handle -> IO r) -> IO r
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
ReadMode (Emitter IO Text -> IO r
eio (Emitter IO Text -> IO r)
-> (Handle -> Emitter IO Text) -> Handle -> IO r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> Emitter IO Text
handleE)
fileWriteC :: FilePath -> Cont IO (Committer IO Text)
fileWriteC :: String -> Cont IO (Committer IO Text)
fileWriteC String
fp = (forall r. (Committer IO Text -> IO r) -> IO r)
-> Cont IO (Committer IO Text)
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont ((forall r. (Committer IO Text -> IO r) -> IO r)
-> Cont IO (Committer IO Text))
-> (forall r. (Committer IO Text -> IO r) -> IO r)
-> Cont IO (Committer IO Text)
forall a b. (a -> b) -> a -> b
$ \Committer IO Text -> IO r
cio -> String -> IOMode -> (Handle -> IO r) -> IO r
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
WriteMode (Committer IO Text -> IO r
cio (Committer IO Text -> IO r)
-> (Handle -> Committer IO Text) -> Handle -> IO r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> Committer IO Text
handleC)
fileAppendC :: FilePath -> Cont IO (Committer IO Text)
fileAppendC :: String -> Cont IO (Committer IO Text)
fileAppendC String
fp = (forall r. (Committer IO Text -> IO r) -> IO r)
-> Cont IO (Committer IO Text)
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont ((forall r. (Committer IO Text -> IO r) -> IO r)
-> Cont IO (Committer IO Text))
-> (forall r. (Committer IO Text -> IO r) -> IO r)
-> Cont IO (Committer IO Text)
forall a b. (a -> b) -> a -> b
$ \Committer IO Text -> IO r
cio -> String -> IOMode -> (Handle -> IO r) -> IO r
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
AppendMode (Committer IO Text -> IO r
cio (Committer IO Text -> IO r)
-> (Handle -> Committer IO Text) -> Handle -> IO r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> Committer IO Text
handleC)
cRef :: (C.MonadConc m) => m (Committer m a, m [a])
cRef :: m (Committer m a, m [a])
cRef = do
IORef m (Seq a)
ref <- Seq a -> m (IORef m (Seq a))
forall (m :: * -> *) a. MonadConc m => a -> m (IORef m a)
C.newIORef Seq a
forall a. Seq a
Seq.empty
let c :: Committer m a
c = (a -> m Bool) -> Committer m a
forall (m :: * -> *) a. (a -> m Bool) -> Committer m a
Committer ((a -> m Bool) -> Committer m a) -> (a -> m Bool) -> Committer m a
forall a b. (a -> b) -> a -> b
$ \a
a -> do
IORef m (Seq a) -> (Seq a -> Seq a) -> m ()
forall (m :: * -> *) a.
MonadConc m =>
IORef m a -> (a -> a) -> m ()
C.modifyIORef IORef m (Seq a)
ref (Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.:|> a
a)
Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
let res :: m [a]
res = Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq a -> [a]) -> m (Seq a) -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef m (Seq a) -> m (Seq a)
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
C.readIORef IORef m (Seq a)
ref
(Committer m a, m [a]) -> m (Committer m a, m [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Committer m a
c, m [a]
res)
eRef :: (C.MonadConc m) => [a] -> m (Emitter m a)
eRef :: [a] -> m (Emitter m a)
eRef [a]
xs = do
IORef m [a]
ref <- [a] -> m (IORef m [a])
forall (m :: * -> *) a. MonadConc m => a -> m (IORef m a)
C.newIORef [a]
xs
let e :: 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
[a]
as <- IORef m [a] -> m [a]
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
C.readIORef IORef m [a]
ref
case [a]
as of
[] -> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
(a
x : [a]
xs') -> do
IORef m [a] -> [a] -> m ()
forall (m :: * -> *) a. MonadConc m => IORef m a -> a -> m ()
C.writeIORef IORef m [a]
ref [a]
xs'
Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
Emitter m a -> m (Emitter m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Emitter m a
e