home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / prelude / PreludeIO.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  7.0 KB  |  241 lines  |  [TEXT/YHS2]
  1. module PreludeMonadicIO (
  2.   Handle,
  3.   stdin, stdout, stderr, stdnull, openFile, openChan, flush, close,
  4.   ready, hGetChar, getContents, hPutChar, setBuffering, setEchoing,
  5.   seek, query, select, deleteFile, statusFile, statusChan, getArgs,
  6.   getProgName, getEnv, setEnv, getClock, getCpuTime, runProcess,
  7.   setInterrupt,
  8.   IO(..), SystemState_, IOResult_, IOError(..), IOMode(..), BufferMode(..),
  9.   HandleState(..), HandleKind(..), OpenClosed(..), FileChan(..), SelectData(..),
  10.   showError, return, (>>=), failwith, try, (>>), fail, getChar, getLine,
  11.   hGetLine,
  12.   hPutStr, hPutText, putChar, putStr, putText, interact, readFile,
  13.   readChan, appendFile, appendChan, writeFile, system,
  14.   accumulate, accumulate_
  15.   ) where
  16.  
  17. import PreludeBltinIO
  18.  
  19. {-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
  20.  
  21.  
  22. -- We do not implement the IO type using PrimIO and the Either type, as
  23. -- described in the Haskell 1.3 proposal.  Instead, failwith and try
  24. -- (the functions for signalling and handling IOErrors, respectively)
  25. -- are implemented as primitives using the Lisp catch/throw mechanism,
  26. -- and normal IO operations just return the result directly.
  27.  
  28. -- The IO a type is represented as a function that takes a state argument
  29. -- (which is ignored and simply serves to encapsulate the computation)
  30. -- and returns a value of type IOResult a.  This extra level of boxing is
  31. -- necessary to support lazy I/O operations.
  32.  
  33. -- These IO functions are defined as primitives in PreludeBltinIO:
  34. -- (>>=), (>>), failwith, try.
  35.  
  36. type IO a = SystemState_ -> IOResult_ a
  37.  
  38. data SystemState_ = SystemState_
  39. data IOResult_ a = IOResult_ a
  40.  
  41. return :: a -> IO a
  42. return x = \ s -> IOResult_ x
  43. {-# return  :: AlwaysInline #-}   -- Is this correct?  should it be strict?
  44.  
  45. -- This is used internally.
  46. getIOResult :: IOResult_ a -> a
  47. getIOResult (IOResult_ x) = x
  48. {-# getIOResult :: AlwaysInline #-}
  49.  
  50.  
  51. -- Error stuff.
  52. -- This is actually implemented as a primitive, as is the showError function.
  53.  
  54. data IOError    = WriteError String
  55.         | ReadError String
  56.         | SearchError String
  57.         | FormatError String
  58.         | OtherError String
  59.         | EOF
  60.   deriving Eq
  61.  
  62. instance Text(IOError) where
  63.   showsPrec p e = showString ("<<" ++ (showError e) ++ ">>")
  64.  
  65. {-#
  66. ImportLispType (
  67.   IOError (
  68.     ReadError ("prim.read-error?", "prim.make-read-error",
  69.       "prim.read-error-string"),
  70.     WriteError ("prim.write-error?", "prim.make-write-error",
  71.       "prim.write-error-string"),
  72.     FormatError ("prim.format-error?", "prim.make-format-error",
  73.       "prim.format-error-string"),
  74.     SearchError ("prim.search-error?", "prim.make-search-error",
  75.       "prim.search-error-string"),
  76.     OtherError ("prim.other-error?", "prim.make-other-error",
  77.       "prim.other-error-string"),
  78.     EOF ("prim.eof-error?", "prim.eof-error")
  79.     ))
  80. #-}
  81.  
  82. fail :: String -> IO a
  83. fail = failwith . OtherError
  84. {-# fail  :: AlwaysInline #-}
  85.  
  86.  
  87. -- Handle operations
  88.  
  89. data Handle = Handle
  90.  
  91. instance Text(Handle) where
  92.   showsPrec p h = showString (showHandle h)
  93.  
  94. data HandleState = HandleState String        -- name
  95.                                HandleKind    -- input, output, or both
  96.                                OpenClosed    -- state
  97.                                FileChan      -- seek info
  98.                                BufferMode    -- buffering type
  99.                                Bool          -- echoing on/off
  100.    deriving (Text, Eq)
  101.  
  102. data BufferMode = UnBuffered | LineBuffered | BlockBuffered
  103.    deriving (Text, Eq)
  104.  
  105. data HandleKind = InputOnly | OutputOnly | InputOutput
  106.    deriving (Text, Eq)
  107.  
  108. data OpenClosed = IsOpen | IsClosed | IsSemiClosed
  109.    deriving (Text, Eq)
  110.  
  111. data FileChan   = IsChannel | IsFile Integer Integer
  112.    deriving (Text, Eq)
  113.  
  114. data IOMode = ReadMode | WriteMode | AppendMode
  115.    deriving (Text, Eq)
  116.  
  117.  
  118. {-#
  119. ImportLispType (
  120.   BufferMode (UnBuffered (":unbuffered"), LineBuffered (":line"),
  121.               BlockBuffered (":block")),
  122.   HandleKind (InputOnly (":input-only"), OutputOnly(":output-only"),
  123.               InputOutput (":input-output")),
  124.   OpenClosed (IsOpen (":is-open"), IsClosed (":is-closed"),
  125.               IsSemiClosed (":is-semi-closed")),
  126.   IOMode (ReadMode (":read"), WriteMode (":write"),  AppendMode (":append"))
  127.   )
  128. #-}
  129.  
  130.  
  131. query :: Handle -> IO HandleState
  132.  
  133. query h = hName h >>= \ name ->
  134.           hKind h >>= \ kind ->
  135.           hOpen h >>= \ open ->
  136.           hFile h >>= \ file ->
  137.           hBuff h >>= \ buff ->
  138.       hEcho h >>= \ echo ->
  139.       if file then
  140.          hSize h >>= \ size ->
  141.          hPosn h >>= \ posn ->
  142.          return (HandleState name kind open (IsFile size posn) buff echo)
  143.       else
  144.          return (HandleState name kind open IsChannel buff echo)
  145.  
  146.  
  147. -- Derived I/O operations
  148.  
  149. getChar :: IO Char
  150. getChar = hGetChar stdin
  151.  
  152. hGetLine :: Handle -> IO String
  153. hGetLine h = hGetChar h >>= (\c ->
  154.           if c == '\n' then return []
  155.                           else hGetLine h >>= (\l -> return (c:l)))
  156.  
  157. getLine :: IO String
  158. getLine = hGetLine stdin
  159.  
  160. hPutStr :: Handle -> String -> IO ()
  161. hPutStr handle = foldr (>>) (return ()) . map (hPutChar handle)
  162. {-# hPutStr :: Inline #-}
  163.  
  164. hPutText :: Text a => Handle -> a -> IO ()
  165. hPutText h = hPutStr h . show
  166.  
  167. putChar :: Char -> IO ()
  168. putChar c = hPutChar stdout c
  169.  
  170. putStr :: String -> IO ()
  171. putStr s = hPutStr stdout s
  172.  
  173. putText :: Text a => a -> IO ()
  174. putText a = hPutText stdout a
  175.  
  176. interact :: (String -> String) -> IO ()
  177. interact f = getContents stdin >>= (putStr . f)
  178.  
  179. readFile :: String -> IO String
  180. readFile name = openFile ReadMode name >>= getContents
  181.  
  182. readChan :: String -> IO String
  183. readChan "stdin" = getContents stdin
  184. readChan name    = openChan name >>= getContents
  185.  
  186. appendFile :: String -> String -> IO ()
  187. appendFile name str =
  188.   openFile AppendMode name >>= \ h -> hPutStr h str >> close h
  189.  
  190. appendChan :: String -> String -> IO ()
  191. appendChan "stdout" str = hPutStr stdout str
  192. appendChan "stderr" str = hPutStr stderr str
  193. appendChan name str = fail "appendChan failed (unknown channel name)"
  194.  
  195. writeFile :: String -> String -> IO ()
  196. writeFile name str =
  197.   openFile WriteMode name >>= \ h -> hPutStr h str >> close h
  198.  
  199.  
  200. -- select is not implementable on all of the systems we support, so for
  201. -- now it just signals an error.
  202.  
  203. type SelectData = ([Handle], [Handle], Maybe Integer)
  204. select :: SelectData -> IO (Maybe SelectData)
  205. select _ = fail "select not supported in this implementation"
  206.  
  207.  
  208. -- operating system interaction
  209.  
  210. statusChan :: String -> IO String
  211. statusChan "stdin" = return ""  -- Avoid failure
  212. statusChan "stdout" = return "0 0"
  213. statusChan "stderr" = return "0 0"
  214. statusChan _ = fail "statusChan failed (unknown channel name)"
  215.  
  216. runProcess :: String -> [Handle] -> IO ()
  217. runProcess progname [i,o,e] =
  218.   process progname i o e
  219. runProcess progname _              =
  220.   fail "runProcess failed (bad handle list)"
  221.  
  222.  
  223. setInterrupt :: IO () -> IO (IO ())
  224. setInterrupt _ =
  225.   fail "setInterrupt not support in this implementation"
  226.  
  227.  
  228.  
  229. -- Monadic combinator
  230.  
  231. accumulate :: [IO a] -> IO [a]
  232. accumulate = foldr mcons (return [])
  233. {-# accumulate :: Inline #-}
  234.  
  235. mcons :: IO a -> IO [a] -> IO [a]
  236. mcons p q = p >>= \x -> q >>= \y -> return (x : y)
  237.  
  238. accumulate_ :: [IO a] -> IO ()
  239. accumulate_ = foldr (>>) (return ())  
  240. {-# accumulate_ :: Inline #-}
  241.