{-# 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 #-}

-- | IO actions
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)

-- $setup
-- >>> :set -XOverloadedStrings

-- * console

-- | emit Text from stdin inputs
--
-- >>> :t emit fromStdin
-- emit fromStdin :: IO (Maybe Text)
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

-- | commit to stdout
--
-- >>> commit toStdout ("I'm committed!" :: Text)
-- I'm committed!
-- True
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

-- | finite console emitter
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

-- | finite console committer
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

-- | read from console, throwing away read errors
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

-- | show to stdout
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

-- * handle operations

-- | Emits lines of Text from a handle.
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
"")

-- | Commit lines of Text to a handle.
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

-- | Emits lines of Text from a file.
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)

-- | Commits lines of Text to a file.
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)

-- | Commits lines of Text, appending to a file.
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)

-- | commit to an IORef
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)

-- | emit from a list IORef
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