{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Box.IO
( cStdin_,
cStdin,
cStdin',
eStdin,
readStdin,
eStdout_,
eStdout,
eStdoutM,
eStdout',
cStdout,
cStdout',
eStdin',
showStdout,
getLine,
putLine,
consolePlug,
emitLines,
commitLines,
cCRef,
cCRefM,
toListM,
getCommissions,
getEmissions,
)
where
import Box.Box
import Box.Committer
import Box.Cont
import Box.Emitter
import Box.Plugs
import Box.Stream
import Box.Transducer
import qualified Control.Concurrent.Classy.IORef as C
import qualified Control.Foldl as L
import Control.Lens hiding ((.>), (:>), (<|), (|>))
import Control.Monad
import qualified Control.Monad.Conc.Class as C
import Control.Monad.Conc.Class (STM)
import Control.Monad.IO.Class
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Streaming (Of (..), Stream)
import qualified Streaming.Internal as S
import qualified Streaming.Prelude as S
import System.IO hiding (getLine)
import Prelude hiding (getLine)
cStdin_ :: Committer (STM IO) Text -> IO ()
cStdin_ c = do
a <- Text.getLine
void $ C.atomically $ commit c a
cStdin :: Int -> Committer (STM IO) Text -> IO ()
cStdin n c = replicateM_ n (cStdin_ c)
cStdin' :: Committer (STM IO) Text -> IO ()
cStdin' = forever . cStdin_
eStdin :: Int -> Cont IO (Emitter (STM IO) Text)
eStdin n = cStdin n & emitPlug
readStdin :: Read a => Cont IO (Emitter (STM IO) a)
readStdin = emap (pure . either (const Nothing) Just) . eRead <$> eStdin 1000
eStdout_ :: Emitter (STM IO) Text -> IO ()
eStdout_ e = do
a <- C.atomically $ emit e
case a of
Nothing -> pure ()
Just a' -> Text.putStrLn a'
eStdoutM_ :: Emitter IO Text -> IO ()
eStdoutM_ e = do
a <- emit e
case a of
Nothing -> pure ()
Just a' -> Text.putStrLn a'
eStdout :: Int -> Emitter (STM IO) Text -> IO ()
eStdout n = replicateM_ n . eStdout_
eStdoutM :: Int -> Emitter IO Text -> IO ()
eStdoutM n = replicateM_ n . eStdoutM_
eStdout' :: Emitter (STM IO) Text -> IO ()
eStdout' = forever . eStdout_
cStdout :: Int -> Cont IO (Committer (STM IO) Text)
cStdout n = eStdout n & commitPlug
cStdout' :: Cont IO (Committer (STM IO) Text)
cStdout' = eStdout' & commitPlug
eStdin' :: Cont IO (Emitter (STM IO) Text)
eStdin' = cStdin' & emitPlug
showStdout :: Show a => Cont IO (Committer (STM IO) a)
showStdout = contramap (Text.pack . show) <$> (cStdout 1000 :: Cont IO (Committer (STM IO) Text))
getLine_ :: Handle -> Committer (STM IO) Text -> IO ()
getLine_ h c = do
a <- Text.hGetLine h
void $ C.atomically $ commit c a
getLine :: Handle -> Committer (STM IO) Text -> IO ()
getLine h = forever . getLine_ h
putLine_ :: Handle -> Emitter (STM IO) Text -> IO ()
putLine_ h e = do
a <- C.atomically $ emit e
case a of
Nothing -> pure ()
Just a' -> Text.hPutStrLn h a'
putLine :: Handle -> Emitter (STM IO) Text -> IO ()
putLine h = forever . putLine_ h
consolePlug :: Int -> Cont IO (Box (STM IO) Text Text)
consolePlug n = boxPlug (eStdout n) (cStdin n)
emitLines :: FilePath -> Cont IO (Emitter (STM IO) Text)
emitLines filePath = Cont (withFile filePath ReadMode) >>= (toEmit . fromHandle)
where
fromHandle :: Handle -> Stream (Of Text) IO ()
fromHandle h =
forever $ do
a <- liftIO $ Text.hGetLine h
S.yield a
commitLines :: FilePath -> Cont IO (Committer (STM IO) Text)
commitLines filePath =
Cont (withFile filePath WriteMode) >>= (toCommit . toHandle)
where
toHandle h = loop
where
loop str =
case str of
S.Return r -> return r
S.Effect m -> m >>= loop
S.Step (s :> rest) -> do
liftIO (Text.hPutStrLn h s)
loop rest
cCRef :: (C.MonadConc m) => m (C.IORef m [b], Cont m (Committer (C.STM m) b), m [b])
cCRef = do
ref <- C.newIORef []
let c =
toCommitFold $
L.FoldM (\x a -> C.modifyIORef x (a :) >> pure x) (pure ref) (const $ pure ())
let res = reverse <$> C.readIORef ref
pure (ref, c, res)
cCRefM :: (C.MonadConc m, Monoid a) => m (C.IORef m a, Cont m (Committer (C.STM m) a), m a)
cCRefM = do
ref <- C.newIORef mempty
let c =
toCommitFold $
L.FoldM (\x a -> C.modifyIORef x (a <>) >> pure x) (pure ref) (const $ pure ())
let res = C.readIORef ref
pure (ref, c, res)
toListM :: (C.MonadConc m) => Cont m (Emitter (C.STM m) a) -> s -> Transducer s a b -> m ([b], s)
toListM e s t = do
(_, c, res) <- cCRef
r <- etc s t (Box <$> c <*> e)
(,) <$> res <*> pure r
getCommissions :: (C.MonadConc m) => Cont m (Emitter (C.STM m) a) -> s -> Transducer s a b -> m [b]
getCommissions e s t = fst <$> toListM e s t
getEmissions :: (C.MonadConc m) => Int -> Cont m (Emitter (C.STM m) a) -> m [a]
getEmissions n e = fst <$> toListM e () (Transducer $ S.take n)