From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 progs/prelude/PreludeLocalIO.hs | 144 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 144 insertions(+)
 create mode 100644 progs/prelude/PreludeLocalIO.hs

(limited to 'progs/prelude/PreludeLocalIO.hs')

diff --git a/progs/prelude/PreludeLocalIO.hs b/progs/prelude/PreludeLocalIO.hs
new file mode 100644
index 0000000..2753071
--- /dev/null
+++ b/progs/prelude/PreludeLocalIO.hs
@@ -0,0 +1,144 @@
+module PreludeLocalIO where
+
+import PreludeIOPrims
+import PreludeIOMonad
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+data IOResponse a = Succ a | Fail String deriving Text
+
+exec :: ([Response] -> [Request]) -> IO ()
+{-
+-- Sunderesh's original definition
+exec p = case (p bottom) of
+          [] -> unitIO ()
+          (q:qs) -> processRequest q `bindIO` \r ->
+                    exec (\rs -> tail (p (r:rs)))
+
+bottom :: a
+bottom = error "Should never be evaluated"
+-}
+-- modified from the existing compiler. no quadratic behavior
+-- needs
+-- pure :: IO a -> a
+-- other alternatives:
+-- 1. use reference cells
+-- 2. implement exec in Lisp
+
+exec p = os requests `bindIO` \x -> unitIO () where
+    requests = p responses
+    responses = pureIO (os requests)
+
+os :: [Request] -> IO [Response]
+os [] = unitIO []
+os (q:qs) = processRequest q `bindIO` \r ->
+            os qs `bindIO` \rs -> 
+            unitIO (r:rs)
+
+processRequest :: Request -> IO Response
+
+-- This needs to be rewritten in terms of the continuation based defs
+
+processRequest request =
+  case request of
+
+-- File system requests
+   ReadFile name ->
+      primReadStringFile name `bindIO` \a -> 
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   WriteFile name contents ->
+      primWriteStringFile name contents `bindIO` \a -> 
+        case a of 
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   AppendFile name contents ->
+      primAppendStringFile name contents `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   ReadBinFile name ->
+      primReadBinFile name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Bn s) 
+          Fail e -> unitIO (Failure e)
+   WriteBinFile name bin ->
+      primWriteBinFile name bin `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   AppendBinFile name bin ->
+      primAppendBinFile name bin `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   DeleteFile name ->
+      primDeleteFile name `bindIO` \a ->
+        case a of 
+          MaybeNot -> Success
+          Maybe e  -> unitIO (Failure e)
+   StatusFile name ->
+      primStatusFile name `bindIO` \a -> 
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+
+-- Channel system requests
+   ReadChan name ->
+      primReadChan name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   AppendChan name string ->
+      primAppendChan name string `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   ReadBinChan name ->
+      primReadBinChan name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Bn s)
+          Fail e -> unitIO (Failure e)
+   AppendBinChan name bin ->
+      primAppendBinChan name bin `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   StatusChan name ->
+      primStatusChan name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+
+-- Environment requests
+   Echo status ->
+      primEcho status `bindIO` \a -> 
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   GetArgs ->
+      primGetArgs `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   GetProgName ->
+      primProgArgs `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   GetEnv name ->
+      primGetEnv name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   SetEnv name string ->
+      primGetEnv name string `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   _ -> unitIO (Failure (OtherError "Unrecognized IO Feature"))
+
+-- Monadic Style IO
+-- Channel system requests
+
-- 
cgit v1.2.3