{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE TupleSections #-}

{-|
Module      : System.IO.Dialogue
Description : Stream-based I/O.
Copyright   : (c) Alias Qli, 2022
License     : BSD-3-Clause
Maintainer  : 2576814881@qq.com
Stability   : experimental
Portability : POSIX

This module implements stream-based I/O as described in Haskell Report 1.2.

As th resport says, "Haskell's I/O system is based on the view that a program communicates to
the outside world via /streams of messages/: a program issues a stream of /requests/ to the
operating system and in  return receives a stream of /responses/." And a stream in Haskell is
only a lazy list.
-}

module System.IO.Dialogue
  ( -- * The Program Type
    Dialogue
  , -- ** Request Types
    Request (..)
  ,  -- *** The Binary Type
    Bin
  , nullBin
  , appendBin
  , isNullBin
  , -- *** The 'Name' Type
    Name
  , -- **** Channels
    stdin
  , stdout
  , stderr
  , stdecho
  , -- ** Response Types
    Response (..)
  , IOError (..)
  , -- * Run the Program
    runDialogue
  ) where

import           Control.Concurrent   (newChan, readChan, writeChan)
import           Control.Monad
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
import           Data.Function        ((&))
import           GHC.IO
import           Prelude              hiding (IOError)
import           System.Directory
import           System.Environment   (getArgs, getProgName, lookupEnv, setEnv)
import           System.IO            hiding (stderr, stdin, stdout)
import qualified System.IO            as Handle

-- * The Program Type

-- | Type of a Haskell program.
-- @['Response']@ is an ordered list of /responses/ and @['Request']@ is an ordered list of /requests/;
-- the /n/th response is the operating system's reply to the /n/th request.
type Dialogue = [Response] -> [Request]

-- | /Requests/ a program may issue.
data Request
  -- file system requests:
  = -- | @'ReadFile' name@ returns the contents of file @name@.
    --
    --   * If successful, the response will be of the form @'Str' s@, where @s@ is a string value;
    --
    --   * If the file does not exist, the response @'Failure' ('SearchError' string)@ is induced;
    --
    --   * If it is unreachable for some other reason, the @'Failure' ('ReadError' string)@ error is induced.
    ReadFile Name
  | -- | @'WriteFile' name string@ writes @string@ to file @name@. If the file does not exist, it is
    -- created. If it already exists, it is overwritten.
    --
    --   * A successful response has form @'Success'@;
    --
    --   * The only failure possible has the form @'Failure' ('WriteError' string)@.
    --
    -- This request is "hyperstrict" in its second argument: no response is
    -- returned until the entire list of values is completely evaluated.
    WriteFile Name String
  | -- | Identicle to 'WriteFile', except that
    --
    --   (1) the @string@ argument is appended to the current contents of the file named @name@;
    --
    --   (2) If the file does not exist, the response @'Failure' ('SearchError' string)@ is induced.
    --
    -- All other errors have form @'Failure' ('WriteError' string)@,
    -- and the request is hyperstrict in its second argument.
    AppendFile Name String
  | -- | Similar to 'ReadFile', except that if successful, the response will be of the form @'Bn' b@,
    -- where @b@ is a binary value.
    ReadBinFile Name
  | -- | Similar to 'WriteFile', except that it writes a binary value to file.
    WriteBinFile Name Bin
  | -- | Similar to 'AppendFile', except that it writes a binary value to file.
    AppendBinFile Name Bin
  | -- | @'DeleteFile' name@ delete file @name@, with successful response @'Success'@.
    --
    --   * If the file does not exist, the response @'Failure' ('SearchError' string)@ is induced.
    --
    --   * If it cannot be deleted for some other reason,
    --     a response of the form @'Failure' ('WriteError' string)@ is induced.
    DeleteFile Name
  | -- | @'StatusFile' name@ induce @'Failure' ('SearchError' string)@ if an object @name@ does not exist,
    -- or @'Failure' ('OtherError' string)@ if any other error should occur. Otherwise induce
    -- @'Str' status@ where @ststus@ is a string containing, in this order:
    --
    --   (1) Either \'f', \'d', or \'u' depending on whether the object is a file, directory,
    --       or something else, respectively;
    --
    --   (2) \'r' if the object is readable by this program, \'-' if not;
    --
    --   (3) \'w' if the object is writable by this program, \'-' if not;
    --
    --   (4) \'x' if the object is executable by this program, \'-' if not.
    --
    -- For example, "dr--" denotes a directory that can be read but not written or executed.
    StatusFile Name
  -- channel system requests:
  | -- | @'ReadChan' name@ opens channel @name@ for input.
    --
    --   * A successful response returns the contents of the channel as a lazy stream of characters.
    --
    --   * If the channel does not exist, the response @'Failure' ('SearchError' string)@ is induced;
    --
    --   * All other errors have form @'Failure' ('ReadError' string)@.
    --
    -- Unlike files, once a 'ReadChan' or 'ReadBinChan' request has been issued for a particular channel,
    -- it cannot be issued again for the same channel in that program, This reflects the ephemeral nature
    -- of its contents and prevents a serious space leak.
    --
    -- /Known issue/: This request would leave the handle behind the channel in /semi-closed/ state,
    -- causing any other attempt to read from the channel to fail. This should be problematic if your program
    -- issued an request to read from @stdin@, and
    --
    --   (1) You called Haskell functions that read from @stdin@ (/e.g./ 'getLine'), or ran another program
    --       that issues such a request after the program finishes.
    --
    --   (2) You're running the program from @ghci@.
    ReadChan Name
  | -- | @'AppendChan' name string@ writes @string@ to channel @name@. The sematics is as for 'AppendFile', except:
    --
    --   (1) The second argument is appended to whatever was previously written (if anything);
    --
    --   (2) If channel does not exist, the response @'Failure' ('SearchError' string)@ is induced.
    --
    -- All other errors have form @'Failure' ('WriteError' string)@.
    -- This request is hyperstrict in its second argument.
    AppendChan Name String
  | -- | Similar to 'ReadChan', except that if successful, the response will be of the form @'Bn' b@,
    -- where @b@ is a lazy binary value.
    ReadBinChan Name
  | -- | Similar to 'AppendChan', except that it writes a binary value to the channel.
    AppendBinChan Name Bin
  | -- | @'StatusChan' name@ induces @'Failure' ('SearchError' string)@ if an channel @name@ does not exist,
    -- otherwise it always induces @'Str' "0 0"@. The two @"0"@s indicate that there's no bound on the
    -- maximum line length and page length allowed on the channel, respectively.
    StatusChan Name
  -- environment requests:
  | -- | @'Echo' 'True'@ enables echoing of @stdin@ on @stdecho@; @'Echo' 'False'@ disables it. Either
    -- @'Success'@ or @'Failure' ('OtherError' string)@ is induced.
    --
    -- The report requires that the echo mode can only be set once by a particular program, before any
    -- I/O operation involving @stdin@. However, the restriction is loosened, and echo mode may be set
    -- at any time by the proogram multiple times.
    --
    -- /Known issue/: It's currently implemented as 'hSetEcho', which is known not to work on Windows.
    Echo Bool
  | -- | Induces the response @'StrList' str_list@, where @str_list@ is a list of the program's explicit
    -- command line arguments.
    GetArgs
  | -- | Returns the short name of the current program, not including search path information. If successful,
    -- the response will be of the form @'Str' s@, where @s@ is a string. If the operating system is unable
    -- to provbide the program name, @'Failure' ('OtherError' string)@ is induced.
    GetProgName
  | -- | @'GetEnv' name@ Returns the value of environment variable @name@. If successful, the response will be
    -- of the form @'Str' s@, where @s@ is a string. If the environment variable does not exist,
    -- a 'SearchError' is induced.
    GetEnv Name
  | -- | @'SetEnv' name string@ sets environment variable @name@ to @string@, with response @'Success'@.
    -- If the environment variable does not exist, it is created.
    SetEnv Name String
  deriving (ReadPrec [Request]
ReadPrec Request
Int -> ReadS Request
ReadS [Request]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Request]
$creadListPrec :: ReadPrec [Request]
readPrec :: ReadPrec Request
$creadPrec :: ReadPrec Request
readList :: ReadS [Request]
$creadList :: ReadS [Request]
readsPrec :: Int -> ReadS Request
$creadsPrec :: Int -> ReadS Request
Read, Int -> Request -> ShowS
[Request] -> ShowS
Request -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> Name
$cshow :: Request -> Name
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show, Request -> Request -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c== :: Request -> Request -> Bool
Eq, Eq Request
Request -> Request -> Bool
Request -> Request -> Ordering
Request -> Request -> Request
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Request -> Request -> Request
$cmin :: Request -> Request -> Request
max :: Request -> Request -> Request
$cmax :: Request -> Request -> Request
>= :: Request -> Request -> Bool
$c>= :: Request -> Request -> Bool
> :: Request -> Request -> Bool
$c> :: Request -> Request -> Bool
<= :: Request -> Request -> Bool
$c<= :: Request -> Request -> Bool
< :: Request -> Request -> Bool
$c< :: Request -> Request -> Bool
compare :: Request -> Request -> Ordering
$ccompare :: Request -> Request -> Ordering
Ord)

-- | 'Bin' is a datatype for binary values, as required by the report, and is implemented as a lazy 'ByteString'.
type Bin = ByteString

-- | The empty binary value.
nullBin :: Bin
nullBin :: Bin
nullBin = Bin
LBS.empty

-- | Append two 'Bin's.
appendBin :: Bin -> Bin -> Bin
appendBin :: Bin -> Bin -> Bin
appendBin = Bin -> Bin -> Bin
LBS.append

-- | Test whether a 'Bin' is empty.
isNullBin :: Bin -> Bool
isNullBin :: Bin -> Bool
isNullBin = Bin -> Bool
LBS.null

-- | This type synonym is described in Haskell Report 1.0, and exists for backward compatibility.
type Name = String

-- | The @stdin@ channel. Readable.
stdin :: Name
stdin :: Name
stdin = Name
"stdin"

-- | The @stdout@ channel. Writable.
stdout :: Name
stdout :: Name
stdout = Name
"stdout"

-- | The @stderr@ channel. Writable.
stderr :: Name
stderr :: Name
stderr = Name
"stderr"

-- | The @stdecho@ channel. Writable. Attached to @stdout@.
stdecho :: Name
stdecho :: Name
stdecho = Name
"stdecho"

data ChanMode = R | A deriving ChanMode -> ChanMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChanMode -> ChanMode -> Bool
$c/= :: ChanMode -> ChanMode -> Bool
== :: ChanMode -> ChanMode -> Bool
$c== :: ChanMode -> ChanMode -> Bool
Eq

mapChan :: Name -> Maybe (Handle, ChanMode)
mapChan :: Name -> Maybe (Handle, ChanMode)
mapChan = \case
  Name
"stdin"   -> forall a. a -> Maybe a
Just (Handle
Handle.stdin, ChanMode
R)
  Name
"stdout"  -> forall a. a -> Maybe a
Just (Handle
Handle.stdout, ChanMode
A)
  Name
"stderr"  -> forall a. a -> Maybe a
Just (Handle
Handle.stderr, ChanMode
A)
  Name
"stdecho" -> forall a. a -> Maybe a
Just (Handle
Handle.stdout, ChanMode
A)
  Name
_         -> forall a. Maybe a
Nothing

-- | /Responses/ a program may receive.
data Response
  = Success
  | Str String
  | StrList [String]
  | Bn Bin
  | Failure IOError
  deriving (ReadPrec [Response]
ReadPrec Response
Int -> ReadS Response
ReadS [Response]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Response]
$creadListPrec :: ReadPrec [Response]
readPrec :: ReadPrec Response
$creadPrec :: ReadPrec Response
readList :: ReadS [Response]
$creadList :: ReadS [Response]
readsPrec :: Int -> ReadS Response
$creadsPrec :: Int -> ReadS Response
Read, Int -> Response -> ShowS
[Response] -> ShowS
Response -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> Name
$cshow :: Response -> Name
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show, Response -> Response -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c== :: Response -> Response -> Bool
Eq, Eq Response
Response -> Response -> Bool
Response -> Response -> Ordering
Response -> Response -> Response
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Response -> Response -> Response
$cmin :: Response -> Response -> Response
max :: Response -> Response -> Response
$cmax :: Response -> Response -> Response
>= :: Response -> Response -> Bool
$c>= :: Response -> Response -> Bool
> :: Response -> Response -> Bool
$c> :: Response -> Response -> Bool
<= :: Response -> Response -> Bool
$c<= :: Response -> Response -> Bool
< :: Response -> Response -> Bool
$c< :: Response -> Response -> Bool
compare :: Response -> Response -> Ordering
$ccompare :: Response -> Response -> Ordering
Ord)

data IOError
  = WriteError String
  | ReadError String
  | SearchError String
  | -- | Since we're using a modern device and the maximum line length and page length
    -- allowed on the channel have no bound, this error would never occur.
    FormatError String
  | OtherError String
  deriving (ReadPrec [IOError]
ReadPrec IOError
Int -> ReadS IOError
ReadS [IOError]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IOError]
$creadListPrec :: ReadPrec [IOError]
readPrec :: ReadPrec IOError
$creadPrec :: ReadPrec IOError
readList :: ReadS [IOError]
$creadList :: ReadS [IOError]
readsPrec :: Int -> ReadS IOError
$creadsPrec :: Int -> ReadS IOError
Read, Int -> IOError -> ShowS
[IOError] -> ShowS
IOError -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [IOError] -> ShowS
$cshowList :: [IOError] -> ShowS
show :: IOError -> Name
$cshow :: IOError -> Name
showsPrec :: Int -> IOError -> ShowS
$cshowsPrec :: Int -> IOError -> ShowS
Show, IOError -> IOError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IOError -> IOError -> Bool
$c/= :: IOError -> IOError -> Bool
== :: IOError -> IOError -> Bool
$c== :: IOError -> IOError -> Bool
Eq, Eq IOError
IOError -> IOError -> Bool
IOError -> IOError -> Ordering
IOError -> IOError -> IOError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IOError -> IOError -> IOError
$cmin :: IOError -> IOError -> IOError
max :: IOError -> IOError -> IOError
$cmax :: IOError -> IOError -> IOError
>= :: IOError -> IOError -> Bool
$c>= :: IOError -> IOError -> Bool
> :: IOError -> IOError -> Bool
$c> :: IOError -> IOError -> Bool
<= :: IOError -> IOError -> Bool
$c<= :: IOError -> IOError -> Bool
< :: IOError -> IOError -> Bool
$c< :: IOError -> IOError -> Bool
compare :: IOError -> IOError -> Ordering
$ccompare :: IOError -> IOError -> Ordering
Ord)

failWith :: Applicative f => IOError -> f Response
failWith :: forall (f :: * -> *). Applicative f => IOError -> f Response
failWith = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Response
Failure

fileNotFound, chanCantRead, chanCantAppend, chanNotExist, varNotExist :: IOError
fileNotFound :: IOError
fileNotFound   = Name -> IOError
SearchError Name
"File not found."
chanCantRead :: IOError
chanCantRead   = Name -> IOError
ReadError Name
"Can't read from channel."
chanCantAppend :: IOError
chanCantAppend = Name -> IOError
WriteError Name
"Can't append to channel."
chanNotExist :: IOError
chanNotExist   = Name -> IOError
SearchError Name
"Channel doesn't exist."
varNotExist :: IOError
varNotExist    = Name -> IOError
SearchError Name
"Environment variable doesn't exist."

ensureFileExist :: FilePath -> IO Response -> IO Response
ensureFileExist :: Name -> IO Response -> IO Response
ensureFileExist Name
name IO Response
io =
  Name -> IO Bool
doesFileExist Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
fileNotFound
    Bool
True  -> IO Response
io

withMode :: Applicative f => Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode :: forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
mode Handle -> f Response
f = case Name -> Maybe (Handle, ChanMode)
mapChan Name
name of
  Maybe (Handle, ChanMode)
Nothing     -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanNotExist
  Just (Handle
h, ChanMode
m)
    | ChanMode
m forall a. Eq a => a -> a -> Bool
== ChanMode
mode -> Handle -> f Response
f Handle
h
    | ChanMode
mode forall a. Eq a => a -> a -> Bool
== ChanMode
R -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanCantRead
    | Bool
otherwise -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanCantAppend

interpret :: Request -> IO Response
interpret :: Request -> IO Response
interpret Request
req = case Request -> (IO Response, Name -> IOError)
interpret' Request
req of
    (IO Response
io, Name -> IOError
err) -> forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
catchAny IO Response
io (forall (f :: * -> *). Applicative f => IOError -> f Response
failWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IOError
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Name
show)
  where
    interpret' :: Request -> (IO Response, Name -> IOError)
interpret' (ReadFile Name
name)          = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Name -> Response
Str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO Name
readFile Name
name, Name -> IOError
ReadError)
    interpret' (WriteFile Name
name Name
str)     = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Name -> IO ()
writeFile Name
name Name
str, Name -> IOError
WriteError)
    interpret' (AppendFile Name
name Name
str)    = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Name -> IO ()
appendFile Name
name Name
str, Name -> IOError
WriteError)
    interpret' (ReadBinFile Name
name)       = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Bin -> Response
Bn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO Bin
LBS.readFile Name
name, Name -> IOError
ReadError)
    interpret' (WriteBinFile Name
name Bin
bin)  = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Bin -> IO ()
LBS.writeFile Name
name Bin
bin, Name -> IOError
WriteError)
    interpret' (AppendBinFile Name
name Bin
bin) = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Bin -> IO ()
LBS.appendFile Name
name Bin
bin, Name -> IOError
WriteError)
    interpret' (DeleteFile Name
name)        = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> IO ()
removeFile Name
name, Name -> IOError
WriteError)
    interpret' (StatusFile Name
name)        = (, Name -> IOError
OtherError) forall a b. (a -> b) -> a -> b
$ do
      [Bool
p, Bool
f, Bool
d] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. IO a -> IO a
unsafeInterleaveIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ Name
name)) [Name -> IO Bool
doesPathExist, Name -> IO Bool
doesFileExist, Name -> IO Bool
doesDirectoryExist]
      let ty :: Maybe Char
ty = case (Bool
p, Bool
f, Bool
d) of
            (Bool
False, Bool
_, Bool
_) -> forall a. Maybe a
Nothing
            (Bool
_, Bool
True, Bool
_)  -> forall a. a -> Maybe a
Just Char
'f'
            (Bool
_, Bool
_, Bool
True)  -> forall a. a -> Maybe a
Just Char
'd'
            (Bool, Bool, Bool)
_             -> forall a. a -> Maybe a
Just Char
'u'
      case Maybe Char
ty of
        Maybe Char
Nothing -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
fileNotFound
        Just Char
c -> do
          Permissions
s <- Name -> IO Permissions
getPermissions Name
name
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Response
Str
            [ Char
c
            , if Permissions -> Bool
readable Permissions
s then Char
'r' else Char
'-'
            , if Permissions -> Bool
writable Permissions
s then Char
'w' else Char
'-'
            , if Permissions -> Bool
executable Permissions
s then Char
'x' else Char
'-'
            ]
    interpret' (ReadChan Name
name)          = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
R (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Response
Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Name
hGetContents), Name -> IOError
ReadError)
    interpret' (AppendChan Name
name Name
str)    = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
A (\Handle
h -> Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Handle -> Name -> IO ()
hPutStr Handle
h Name
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h)), Name -> IOError
WriteError)
    interpret' (ReadBinChan Name
name)       = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
R (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bin -> Response
Bn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Bin
LBS.hGetContents), Name -> IOError
ReadError)
    interpret' (AppendBinChan Name
name Bin
str) = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
A (\Handle
h -> Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Handle -> Bin -> IO ()
LBS.hPutStr Handle
h Bin
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h)), Name -> IOError
WriteError)
    interpret' (StatusChan Name
name)        = (Name -> Maybe (Handle, ChanMode)
mapChan Name
name forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanNotExist) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Response
Str Name
"0 0"))), Name -> IOError
OtherError)
    interpret' (Echo Bool
b)                 = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Handle -> Bool -> IO ()
hSetEcho Handle
Handle.stdin Bool
b, Name -> IOError
OtherError)
    interpret' Request
GetArgs                  = ([Name] -> Response
StrList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Name]
getArgs, Name -> IOError
OtherError)
    interpret' Request
GetProgName              = (Name -> Response
Str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Name
getProgName, Name -> IOError
OtherError)
    interpret' (GetEnv Name
name)            = (Name -> IO (Maybe Name)
lookupEnv Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
varNotExist) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Response
Str), Name -> IOError
OtherError)
    interpret' (SetEnv Name
name Name
str)        = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Name -> IO ()
setEnv Name
name Name
str, Name -> IOError
OtherError)

-- | The central function to run a program.
runDialogue :: Dialogue -> IO ()
runDialogue :: Dialogue -> IO ()
runDialogue Dialogue
prog = do
  Chan Response
resChan <- forall a. IO (Chan a)
newChan
  let reading :: IO [Response]
reading = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Chan a -> IO a
readChan Chan Response
resChan forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO [Response]
reading
  [Response]
input <- IO [Response]
reading
  let output :: [Request]
output = Dialogue
prog [Response]
input
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Request]
output forall a b. (a -> b) -> a -> b
$ Request -> IO Response
interpret forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. Chan a -> a -> IO ()
writeChan Chan Response
resChan