{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Box.IO
( fromStdin,
toStdout,
fromStdinN,
toStdoutN,
readStdin,
showStdout,
handleE,
handleC,
refCommitter,
refEmitter,
fileE,
fileWriteC,
fileAppendC,
)
where
import Box.Committer
import Box.Connectors
import Box.Codensity
import Box.Emitter
import qualified Control.Concurrent.Classy.IORef as C
import Control.Exception
import qualified Control.Monad.Conc.Class as C
import Data.Bool
import Data.Foldable
import qualified Data.Sequence as Seq
import Data.Text as Text
import Data.Text.IO as Text
import System.IO as IO
import Prelude
import Data.Functor.Contravariant
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
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 (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 -> CoEmitter IO Text
fromStdinN :: Int -> CoEmitter IO Text
fromStdinN Int
n = Int -> IO Text -> CoEmitter IO Text
forall (m :: * -> *) a. MonadConc m => Int -> m a -> CoEmitter m a
source Int
n IO Text
Text.getLine
toStdoutN :: Int -> CoCommitter IO Text
toStdoutN :: Int -> CoCommitter IO Text
toStdoutN Int
n = Int -> (Text -> IO ()) -> CoCommitter IO Text
forall (m :: * -> *) a.
MonadConc m =>
Int -> (a -> m ()) -> CoCommitter m a
sink Int
n Text -> IO ()
Text.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
witherE (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 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
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 (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
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
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 ()
Text.hPutStrLn Handle
h Text
a
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
fileE :: FilePath -> CoEmitter IO Text
fileE :: String -> CoEmitter IO Text
fileE String
fp = (forall b. (Emitter IO Text -> IO b) -> IO b) -> CoEmitter IO Text
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Emitter IO Text -> IO b) -> IO b)
-> CoEmitter IO Text)
-> (forall b. (Emitter IO Text -> IO b) -> IO b)
-> CoEmitter IO Text
forall a b. (a -> b) -> a -> b
$ \Emitter IO Text -> IO b
eio -> String -> IOMode -> (Handle -> IO b) -> IO b
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
ReadMode (Emitter IO Text -> IO b
eio (Emitter IO Text -> IO b)
-> (Handle -> Emitter IO Text) -> Handle -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Emitter IO Text
handleE)
fileWriteC :: FilePath -> CoCommitter IO Text
fileWriteC :: String -> CoCommitter IO Text
fileWriteC String
fp = (forall b. (Committer IO Text -> IO b) -> IO b)
-> CoCommitter IO Text
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Committer IO Text -> IO b) -> IO b)
-> CoCommitter IO Text)
-> (forall b. (Committer IO Text -> IO b) -> IO b)
-> CoCommitter IO Text
forall a b. (a -> b) -> a -> b
$ \Committer IO Text -> IO b
cio -> String -> IOMode -> (Handle -> IO b) -> IO b
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
WriteMode (Committer IO Text -> IO b
cio (Committer IO Text -> IO b)
-> (Handle -> Committer IO Text) -> Handle -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Committer IO Text
handleC)
fileAppendC :: FilePath -> CoCommitter IO Text
fileAppendC :: String -> CoCommitter IO Text
fileAppendC String
fp = (forall b. (Committer IO Text -> IO b) -> IO b)
-> CoCommitter IO Text
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Committer IO Text -> IO b) -> IO b)
-> CoCommitter IO Text)
-> (forall b. (Committer IO Text -> IO b) -> IO b)
-> CoCommitter IO Text
forall a b. (a -> b) -> a -> b
$ \Committer IO Text -> IO b
cio -> String -> IOMode -> (Handle -> IO b) -> IO b
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
AppendMode (Committer IO Text -> IO b
cio (Committer IO Text -> IO b)
-> (Handle -> Committer IO Text) -> Handle -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Committer IO Text
handleC)
refCommitter :: (C.MonadConc m) => m (Committer m a, m [a])
refCommitter :: m (Committer m a, m [a])
refCommitter = 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)
refEmitter :: (C.MonadConc m) => [a] -> m (Emitter m a)
refEmitter :: [a] -> m (Emitter m a)
refEmitter [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