diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +# Changelog for dialogue + +## 0.1.0 2022-02-13 + - First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alias Qli (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alias Qli nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# dialogue + +Implement I/O described in Haskell Report 1.2, including stream-based and continuation-based I/O. You may want to [read the report](https://www.haskell.org/definition/haskell-report-1.2.ps.gz) or see the [examples](examples/Main.hs). diff --git a/dialogue.cabal b/dialogue.cabal new file mode 100644 --- /dev/null +++ b/dialogue.cabal @@ -0,0 +1,62 @@ +cabal-version: 2.4 + +name: dialogue +version: 0.1.0 +category: IO +synopsis: I/O in Haskell Report 1.2 +description: Please see the README on GitHub at +homepage: https://github.com/AliasQli/dialogue#readme +bug-reports: https://github.com/AliasQli/dialogue/issues +author: Alias Qli +maintainer: 2576814881@qq.com +copyright: 2022 Alias Qli +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/AliasQli/dialogue + +library + exposed-modules: + System.IO.Continuation + System.IO.Dialogue + hs-source-dirs: + src + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wno-name-shadowing + -Wno-orphans + build-depends: + base >= 4.7 && < 5 + , bytestring >= 0.10.12 && < 0.11 + , directory >= 1.3.6 && < 1.4 + default-language: Haskell2010 + +executable examples + main-is: Main.hs + hs-source-dirs: + examples + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wno-name-shadowing + -Wno-orphans + -threaded + -rtsopts + -with-rtsopts=-N + build-depends: + base >= 4.7 && < 5 + , dialogue + default-language: Haskell2010 diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +-- | Here are some examples from the report. +module Main where + +import Prelude hiding (readFile) +import System.IO.Continuation +import System.IO.Dialogue + +-- | A small example using the stream-based I/O. Note the irrefutable patterns! +example1 :: Dialogue +example1 ~(Success: ~((Str userInput) : ~(Success : ~(r4 : _)))) = + [ AppendChan stdout "please type a filename\n" + , ReadChan stdin + , AppendChan stdout name + , ReadFile name + , AppendChan stdout (case r4 of Str contents -> contents + Failure ioerror -> "can't open file") + , AppendChan stdout "\nfinished" + ] where (name : _) = lines userInput + +-- | Same as 'example1', but using the continuation-based I/O. +example2 :: Dialogue +example2 = + appendChan stdout "please type a filename\n" exit ( + readChan stdin exit (\userInput -> + let (name : _) = lines userInput in + appendChan stdout name exit ( + readFile name (\ioerror -> appendChan stdout + "can't open file" exit done) + (\contents -> + appendChan stdout contents exit done)))) + +------------------------------------------------------------ + +-- | An example involving synchronisation. +program :: Dialogue +program = readChan stdin exit (\userInput -> readNums (lines userInput)) + +readNums :: [String] -> Dialogue +readNums inputLines = + readInt "Enter first number: " inputLines + (\num1 inputLines1 -> + readInt "Enter second number: " inputLines1 + (\num2 _ -> reportResult num1 num2)) + +reportResult :: Int -> Int -> Dialogue +reportResult num1 num2 = + appendChan stdout ("Their sum is: " ++ show (num1 + num2)) exit done + +readInt :: String -> [String] -> (Int -> [String] -> Dialogue) -> Dialogue +readInt prompt inputLines succ = + appendChan stdout prompt exit + (case inputLines of + (l1 : rest) -> case reads l1 of + [(x,"")] -> succ x rest + _ -> appendChan stdout + "Error - retype the number\n" exit + (readInt prompt rest succ) + _ -> appendChan stdout "Early EOF" exit done) + +main :: IO () +main = runDialogue program diff --git a/src/System/IO/Continuation.hs b/src/System/IO/Continuation.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Continuation.hs @@ -0,0 +1,174 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +{-| +Module : System.IO.Continuation +Description : Continuation-based I/O. +Copyright : (c) Alias Qli, 2022 +License : BSD-3-Clause +Maintainer : 2576814881@qq.com +Stability : experimental +Portability : POSIX + +This module implements continuation-based I/O as described in Haskell Report 1.2. It shares +the same basic types as stream-based I/O. +-} + +module System.IO.Continuation + ( -- * Continuation Types + SuccCont + , StrCont + , StrListCont + , BinCont + , FailCont + , -- * Transactions + -- | Continuation-based I/O is based on a collection of functions called /transactions/ + -- defined in a continuation style. Please refer to the corresponding constructors under + -- 'Request' for documentations. + done + , readFile + , writeFile + , appendFile + , readBinFile + , writeBinFile + , appendBinFile + , deleteFile + , statusFile + , readChan + , appendChan + , readBinChan + , appendBinChan + , statusChan + , echo + , getArgs + , getProgName + , getEnv + , setEnv + , -- * Other Functions + exit + , abort + , print + , prints + , interact + , -- * Re-exports + -- ** Types + Dialogue + , Bin + , Name + , IOError (..) + , -- ** Channels + stdin + , stdout + , stderr + , stdecho + , -- ** Run the Program + runDialogue + ) where + +import Prelude (Bool, Show (..), String, shows) +import System.IO.Dialogue + +type SuccCont = Dialogue +type StrCont = String -> Dialogue +type StrListCont = [String] -> Dialogue +type BinCont = Bin -> Dialogue +type FailCont = IOError -> Dialogue + +strDispatch :: FailCont -> StrCont -> Dialogue +strDispatch fail succ (resp:resps) = case resp of + Str val -> succ val resps + Failure msg -> fail msg resps + +strListDispatch :: FailCont -> StrListCont -> Dialogue +strListDispatch fail succ (resp:resps) = case resp of + StrList val -> succ val resps + Failure msg -> fail msg resps + +binDispatch :: FailCont -> BinCont -> Dialogue +binDispatch fail succ (resp:resps) = case resp of + Bn val -> succ val resps + Failure msg -> fail msg resps + +succDispatch :: FailCont -> SuccCont -> Dialogue +succDispatch fail succ (resp:resps) = case resp of + Success -> succ resps + Failure msg -> fail msg resps + +done :: Dialogue +done _ = [] + +readFile :: Name -> FailCont -> StrCont -> Dialogue +readFile name fail succ resps = ReadFile name : strDispatch fail succ resps + +writeFile :: Name -> String -> FailCont -> SuccCont -> Dialogue +writeFile name contents fail succ resps = WriteFile name contents : succDispatch fail succ resps + +appendFile :: Name -> String -> FailCont -> SuccCont -> Dialogue +appendFile name contents fail succ resps = AppendFile name contents : succDispatch fail succ resps + +readBinFile :: Name -> FailCont -> BinCont -> Dialogue +readBinFile name fail succ resps = ReadBinFile name : binDispatch fail succ resps + +writeBinFile :: Name -> Bin -> FailCont -> SuccCont -> Dialogue +writeBinFile name contents fail succ resps = WriteBinFile name contents : succDispatch fail succ resps + +appendBinFile :: Name -> Bin -> FailCont -> SuccCont -> Dialogue +appendBinFile name contents fail succ resps = AppendBinFile name contents : succDispatch fail succ resps + +deleteFile :: Name -> FailCont -> SuccCont -> Dialogue +deleteFile name fail succ resps = DeleteFile name : succDispatch fail succ resps + +statusFile :: Name -> FailCont -> StrCont -> Dialogue +statusFile name fail succ resps = StatusFile name : strDispatch fail succ resps + +readChan :: Name -> FailCont -> StrCont -> Dialogue +readChan name fail succ resps = ReadChan name : strDispatch fail succ resps + +appendChan :: Name -> String -> FailCont -> SuccCont -> Dialogue +appendChan name contents fail succ resps = AppendChan name contents : succDispatch fail succ resps + +readBinChan :: Name -> FailCont -> BinCont -> Dialogue +readBinChan name fail succ resps = ReadBinChan name : binDispatch fail succ resps + +appendBinChan :: Name -> Bin -> FailCont -> SuccCont -> Dialogue +appendBinChan name contents fail succ resps = AppendBinChan name contents : succDispatch fail succ resps + +statusChan :: Name -> FailCont -> StrCont -> Dialogue +statusChan name fail succ resps = StatusChan name : strDispatch fail succ resps + +echo :: Bool -> FailCont -> SuccCont -> Dialogue +echo bool fail succ resps = Echo bool : succDispatch fail succ resps + +getArgs :: FailCont -> StrListCont -> Dialogue +getArgs fail succ resps = GetArgs : strListDispatch fail succ resps + +getProgName :: FailCont -> StrCont -> Dialogue +getProgName fail succ resps = GetProgName : strDispatch fail succ resps + +getEnv :: String -> FailCont -> StrCont -> Dialogue +getEnv name fail succ resps = GetEnv name : strDispatch fail succ resps + +setEnv :: String -> String -> FailCont -> SuccCont -> Dialogue +setEnv name value fail succ resps = SetEnv name value : succDispatch fail succ resps + +abort :: FailCont +abort _ = done + +exit :: FailCont +exit err = appendChan stderr msg abort done + where + msg = case err of + ReadError s -> s + WriteError s -> s + SearchError s -> s + FormatError s -> s + OtherError s -> s + +print :: Show a => a -> Dialogue +print x = appendChan stdout (show x) exit done + +prints :: Show a => a -> String -> Dialogue +prints x s = appendChan stdout (shows x s) exit done + +interact :: (String -> String) -> Dialogue +interact f = readChan stdin exit + (\x -> appendChan stdout (f x) exit done) diff --git a/src/System/IO/Dialogue.hs b/src/System/IO/Dialogue.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Dialogue.hs @@ -0,0 +1,322 @@ +{-# 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 (Read, Show, Eq, 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 = LBS.empty + +-- | Append two 'Bin's. +appendBin :: Bin -> Bin -> Bin +appendBin = LBS.append + +-- | Test whether a 'Bin' is empty. +isNullBin :: Bin -> Bool +isNullBin = 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 = "stdin" + +-- | The @stdout@ channel. Writable. +stdout :: Name +stdout = "stdout" + +-- | The @stderr@ channel. Writable. +stderr :: Name +stderr = "stderr" + +-- | The @stdecho@ channel. Writable. Attached to @stdout@. +stdecho :: Name +stdecho = "stdecho" + +data ChanMode = R | A deriving Eq + +mapChan :: Name -> Maybe (Handle, ChanMode) +mapChan = \case + "stdin" -> Just (Handle.stdin, R) + "stdout" -> Just (Handle.stdout, A) + "stderr" -> Just (Handle.stderr, A) + "stdecho" -> Just (Handle.stdout, A) + _ -> Nothing + +-- | /Responses/ a program may receive. +data Response + = Success + | Str String + | StrList [String] + | Bn Bin + | Failure IOError + deriving (Read, Show, Eq, 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 (Read, Show, Eq, Ord) + +failWith :: Applicative f => IOError -> f Response +failWith = pure . Failure + +fileNotFound, chanCantRead, chanCantAppend, chanNotExist, varNotExist :: IOError +fileNotFound = SearchError "File not found." +chanCantRead = ReadError "Can't read from channel." +chanCantAppend = WriteError "Can't append to channel." +chanNotExist = SearchError "Channel doesn't exist." +varNotExist = SearchError "Environment variable doesn't exist." + +ensureFileExist :: FilePath -> IO Response -> IO Response +ensureFileExist name io = + doesFileExist name >>= \case + False -> failWith fileNotFound + True -> io + +withMode :: Applicative f => Name -> ChanMode -> (Handle -> f Response) -> f Response +withMode name mode f = case mapChan name of + Nothing -> failWith chanNotExist + Just (h, m) + | m == mode -> f h + | mode == R -> failWith chanCantRead + | otherwise -> failWith chanCantAppend + +interpret :: Request -> IO Response +interpret req = case interpret' req of + (io, err) -> catchAny io (failWith . err . show) + where + interpret' (ReadFile name) = (ensureFileExist name $ Str <$> readFile name, ReadError) + interpret' (WriteFile name str) = (Success <$ writeFile name str, WriteError) + interpret' (AppendFile name str) = (ensureFileExist name $ Success <$ appendFile name str, WriteError) + interpret' (ReadBinFile name) = (ensureFileExist name $ Bn <$> LBS.readFile name, ReadError) + interpret' (WriteBinFile name bin) = (Success <$ LBS.writeFile name bin, WriteError) + interpret' (AppendBinFile name bin) = (ensureFileExist name $ Success <$ LBS.appendFile name bin, WriteError) + interpret' (DeleteFile name) = (ensureFileExist name $ Success <$ removeFile name, WriteError) + interpret' (StatusFile name) = (, OtherError) $ do + [p, f, d] <- mapM (unsafeInterleaveIO . ($ name)) [doesPathExist, doesFileExist, doesDirectoryExist] + let ty = case (p, f, d) of + (False, _, _) -> Nothing + (_, True, _) -> Just 'f' + (_, _, True) -> Just 'd' + _ -> Just 'u' + case ty of + Nothing -> failWith fileNotFound + Just c -> do + s <- getPermissions name + return $ Str + [ c + , if readable s then 'r' else '-' + , if writable s then 'w' else '-' + , if executable s then 'x' else '-' + ] + interpret' (ReadChan name) = (withMode name R (fmap Str . hGetContents), ReadError) + interpret' (AppendChan name str) = (withMode name A (\h -> Success <$ (hPutStr h str >> hFlush h)), WriteError) + interpret' (ReadBinChan name) = (withMode name R (fmap Bn . LBS.hGetContents), ReadError) + interpret' (AppendBinChan name str) = (withMode name A (\h -> Success <$ (LBS.hPutStr h str >> hFlush h)), WriteError) + interpret' (StatusChan name) = (mapChan name & maybe (failWith chanNotExist) (const (pure (Str "0 0"))), OtherError) + interpret' (Echo b) = (Success <$ hSetEcho Handle.stdin b, OtherError) + interpret' GetArgs = (StrList <$> getArgs, OtherError) + interpret' GetProgName = (Str <$> getProgName, OtherError) + interpret' (GetEnv name) = (lookupEnv name >>= maybe (failWith varNotExist) (pure . Str), OtherError) + interpret' (SetEnv name str) = (Success <$ setEnv name str, OtherError) + +-- | The central function to run a program. +runDialogue :: Dialogue -> IO () +runDialogue prog = do + resChan <- newChan + let reading = unsafeInterleaveIO $ (:) <$> readChan resChan <*> reading + input <- reading + let output = prog input + forM_ output $ interpret >=> writeChan resChan