{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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,
fileEmitter,
fileCommitter,
appendCommitter,
)
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 qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Streaming.Prelude as S
import System.IO hiding (getLine)
import Protolude hiding (getLine, STM)
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 :: Handle -> Emitter IO Text
emitLines h = Emitter $ do
l :: (Either IOException Text) <- try (Text.hGetLine h)
pure $ case l of
Left _ -> Nothing
Right a -> bool (Just a) Nothing (a == "")
commitLines :: Handle -> Committer IO Text
commitLines h = Committer $ \a -> do
Text.hPutStrLn h a
pure True
fileEmitter :: FilePath -> Cont IO (Emitter IO Text)
fileEmitter fp = Cont $ \eio -> withFile fp ReadMode (eio . emitLines)
fileCommitter :: FilePath -> Cont IO (Committer IO Text)
fileCommitter fp = Cont $ \cio -> withFile fp WriteMode (cio . commitLines)
appendCommitter :: FilePath -> Cont IO (Committer IO Text)
appendCommitter fp = Cont $ \cio -> withFile fp AppendMode (cio . commitLines)
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)