diff options
Diffstat (limited to 'progs/prelude/PreludeIO.hs')
| -rw-r--r-- | progs/prelude/PreludeIO.hs | 232 |
1 files changed, 232 insertions, 0 deletions
diff --git a/progs/prelude/PreludeIO.hs b/progs/prelude/PreludeIO.hs new file mode 100644 index 0000000..6173d8c --- /dev/null +++ b/progs/prelude/PreludeIO.hs @@ -0,0 +1,232 @@ +-- I/O functions and definitions + +module PreludeIO(stdin,stdout,stderr,stdecho,{-Request(..),Response(..),-} + IOError(..),Dialogue(..),IO(..),SystemState,IOResult, + SuccCont(..),StrCont(..), + StrListCont(..),BinCont(..),FailCont(..), + readFile, writeFile, appendFile, readBinFile, + writeBinFile, appendBinFile, deleteFile, statusFile, + readChan, appendChan, readBinChan, appendBinChan, + statusChan, echo, getArgs, getProgName, getEnv, setEnv, + done, exit, abort, print, prints, interact, + thenIO,thenIO_,seqIO,returnIO, doneIO) + where + +import PreludeBltinIO +import PreludeBltinArray(strict1) + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- These datatypes are used by the monad. + +type IO a = SystemState -> IOResult a + +data SystemState = SystemState +data IOResult a = IOResult a + +-- Operations in the monad + +-- This definition is needed to allow proper tail recursion of the Lisp +-- code. The use of strict1 forces f1 s (since getState is strict) before +-- the call to f2. The optimizer removed getState and getRes from the +-- generated code. + +{-# thenIO :: Inline #-} +thenIO f1 f2 s = + let g = f1 s + s' = getState g in + strict1 s' (f2 (getRes g) s') + +{-# thenIO_ :: Inline #-} +x `thenIO_` y = x `thenIO` \_ -> y +x `seqIO` y = x `thenIO` \_ -> y + +-- The returnIO function is implemented directly as a primitive. +doneIO = returnIO () + + +-- File and channel names: + +stdin = "stdin" +stdout = "stdout" +stderr = "stderr" +stdecho = "stdecho" + + +-- Requests and responses: + +{- Not used since streams are no longer supported: +data Request = -- file system requests: + ReadFile String + | WriteFile String String + | AppendFile String String + | ReadBinFile String + | WriteBinFile String Bin + | AppendBinFile String Bin + | DeleteFile String + | StatusFile String + -- channel system requests: + | ReadChan String + | AppendChan String String + | ReadBinChan String + | AppendBinChan String Bin + | StatusChan String + -- environment requests: + | Echo Bool + | GetArgs + | GetProgName + | GetEnv String + | SetEnv String String + deriving Text + +data Response = Success + | Str String + | StrList [String] + | Bn Bin + | Failure IOError + deriving Text + +-} + +data IOError = WriteError String + | ReadError String + | SearchError String + | FormatError String + | OtherError String + deriving Text + +-- Continuation-based I/O: + +type Dialogue = IO () +type SuccCont = Dialogue +type StrCont = String -> Dialogue +type StrListCont = [String] -> Dialogue +type BinCont = Bin -> Dialogue +type FailCont = IOError -> Dialogue + +done :: Dialogue +readFile :: String -> FailCont -> StrCont -> Dialogue +writeFile :: String -> String -> FailCont -> SuccCont -> Dialogue +appendFile :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinFile :: String -> FailCont -> BinCont -> Dialogue +writeBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +appendBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +deleteFile :: String -> FailCont -> SuccCont -> Dialogue +statusFile :: String -> FailCont -> StrCont -> Dialogue +readChan :: String -> FailCont -> StrCont -> Dialogue +appendChan :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinChan :: String -> FailCont -> BinCont -> Dialogue +appendBinChan :: String -> Bin -> FailCont -> SuccCont -> Dialogue +statusChan :: String -> FailCont -> StrCont -> Dialogue +echo :: Bool -> FailCont -> SuccCont -> Dialogue +getArgs :: FailCont -> StrListCont -> Dialogue +getProgName :: FailCont -> StrCont -> Dialogue +getEnv :: String -> FailCont -> StrCont -> Dialogue +setEnv :: String -> String -> FailCont -> SuccCont -> Dialogue + +done = returnIO () + +readFile name fail succ = + primReadStringFile name `thenIO` objDispatch fail succ + +writeFile name contents fail succ = + primWriteStringFile name contents `thenIO` succDispatch fail succ + +appendFile name contents fail succ = + primAppendStringFile name contents `thenIO` succDispatch fail succ + +readBinFile name fail succ = + primReadBinFile name `thenIO` objDispatch fail succ + +writeBinFile name contents fail succ = + primWriteBinFile name contents `thenIO` succDispatch fail succ + +appendBinFile name contents fail succ = + primAppendBinFile name contents `thenIO` succDispatch fail succ + +deleteFile name fail succ = + primDeleteFile name `thenIO` succDispatch fail succ + +statusFile name fail succ = + primStatusFile name `thenIO` + (\status -> case status of Succ s -> succ s + Fail msg -> fail (SearchError msg)) + +readChan name fail succ = + if name == stdin then + primReadStdin `thenIO` succ + else + badChan fail name + +appendChan name contents fail succ = + if name == stdout then + primWriteStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +readBinChan name fail succ = + if name == stdin then + primReadBinStdin `thenIO` objDispatch fail succ + else + badChan fail name + +appendBinChan name contents fail succ = + if name == stdout then + primWriteBinStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +statusChan name fail succ = + if name == stdin || name == stdout then + succ "0 0" + else + fail (SearchError "Channel not defined") + +echo bool fail succ = + if bool then + succ + else + fail (OtherError "Echo cannot be turned off") + +getArgs fail succ = + succ [""] + +getProgName fail succ = + succ "haskell" + +getEnv name fail succ = + primGetEnv name `thenIO` objDispatch fail succ + +setEnv name val fail succ = + fail (OtherError "setEnv not implemented") + +objDispatch fail succ r = + case r of Succ s -> succ s + Fail msg -> fail (OtherError msg) + +succDispatch fail succ r = + case r of Succ _ -> succ + Fail msg -> fail (OtherError msg) + +badChan f name = f (OtherError ("Improper IO Channel: " ++ name)) + +abort :: FailCont +abort err = done + +exit :: FailCont +exit err = appendChan stderr (msg ++ "\n") abort done + where msg = case err of ReadError s -> s + WriteError s -> s + SearchError s -> s + FormatError s -> s + OtherError s -> s + +print :: (Text a) => a -> Dialogue +print x = appendChan stdout (show x) exit done +prints :: (Text 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) + |