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