{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# 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
, showStdout
, consolePlug
, emitLines
, commitLines
, cCRef
, cCRefM
, toListM
, getCommissions
, getEmissions
) where
import Control.Category
import qualified Control.Foldl as L
import Control.Lens hiding ((:>), (.>), (<|), (|>))
import Data.Semigroup hiding (First, getFirst)
import qualified Data.Text.IO as Text
import Box.Box
import Box.Committer
import Box.Cont
import Box.Emitter
import Box.Plugs
import Box.Stream
import Box.Transducer
import Protolude hiding ((.), (<>), STM)
import Streaming (Of(..), Stream)
import qualified Streaming.Internal as S
import qualified Streaming.Prelude as S
import qualified Control.Monad.Conc.Class as C
import qualified Control.Concurrent.Classy.IORef as C
import Control.Monad.Conc.Class (STM)
cStdin_ :: Committer (STM IO) Text -> IO ()
cStdin_ c = do
a <- getLine
void $ 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_ :: (Print a) => Emitter (STM IO) a -> IO ()
eStdout_ e = do
a <- atomically $ emit e
case a of
Nothing -> pure ()
Just a' -> putStrLn a'
eStdoutM_ :: (Print a) => Emitter IO a -> IO ()
eStdoutM_ e = do
a <- emit e
case a of
Nothing -> pure ()
Just a' -> putStrLn a'
eStdout :: (Print a) => Int -> Emitter (STM IO) a -> IO ()
eStdout n = replicateM_ n . eStdout_
eStdoutM :: (Print a) => Int -> Emitter IO a -> IO ()
eStdoutM n = replicateM_ n . eStdoutM_
eStdout' :: (Print a) => Emitter (STM IO) a -> IO ()
eStdout' = forever . eStdout_
cStdout :: Print a => Int -> Cont IO (Committer (STM IO) a)
cStdout n = eStdout n & commitPlug
showStdout :: Show a => Cont IO (Committer (STM IO) a)
showStdout = contramap show <$> (cStdout 1000 :: Cont IO (Committer (STM IO) Text))
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) >>= (fromHandle >>> toEmit)
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) >>= (toHandle >>> toCommit)
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)