{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

-- | IO effects
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

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Prelude
-- >>> import Box
-- >>> import Data.Bool
-- >>> import Data.Text (Text, pack)
-- >>> import Data.Functor.Contravariant

-- * console

-- | Emit text from stdin
--
-- @
-- λ> emit fromStdin
-- hello
-- Just "hello"
-- @
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

-- | 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 ()
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

-- | Finite console emitter
--
-- @
-- λ> toListM /<$|/> fromStdinN 2
-- hello
-- hello again
-- ["hello","hello again"]
-- @
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

-- | Finite console committer
--
-- >>> glue <$> contramap (pack . show) <$> (toStdoutN 2) <*|> qList [1..3]
-- 1
-- 2
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

-- | Read from console, throwing away read errors
--
-- λ> glueN 2 showStdout (readStdin :: Emitter IO Int)
-- 1
-- 1
-- hippo
-- 2
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

-- | Show to stdout
--
-- >>> glue showStdout <$|> qList [1..3]
-- 1
-- 2
-- 3
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

-- | 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
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 ()
Text.hPutStrLn Handle
h Text
a
  Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

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

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

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

-- | Commit to an IORef
--
-- >>> (c1,l1) <- refCommitter :: IO (Committer IO Int, IO [Int])
-- >>> glue c1 <$|> qList [1..3]
-- >>> l1
-- [1,2,3]
--
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)

-- | Emit from a list IORef
--
-- >>> e <- refEmitter [1..3]
-- >>> toListM e
-- [1,2,3]
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