ghc/lib/std/IO.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section[IO]{Module @IO@}
   5
   6 Implementation of the standard Haskell IO interface, see
   7 @http://haskell.org/onlinelibrary/io.html@ for the official
   8 definition.
   9
  10 \begin{code}
  11 module IO (
  12     Handle,             -- abstract, instance of: Eq, Show.
  13     HandlePosn(..),     -- abstract, instance of: Eq, Show.
  14
  15     IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
  16     BufferMode(NoBuffering,LineBuffering,BlockBuffering),
  17     SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
  18
  19     stdin, stdout, stderr,   -- :: Handle
  20
  21     openFile,                  -- :: FilePath -> IOMode -> IO Handle
  22     hClose,                    -- :: Handle -> IO ()
  23     hFileSize,                 -- :: Handle -> IO Integer
  24     hIsEOF,                    -- :: Handle -> IO Bool
  25     isEOF,                     -- :: IO Bool
  26
  27     hSetBuffering,             -- :: Handle -> BufferMode -> IO ()
  28     hGetBuffering,             -- :: Handle -> IO BufferMode
  29     hFlush,                    -- :: Handle -> IO ()
  30     hGetPosn,                  -- :: Handle -> IO HandlePosn
  31     hSetPosn,                  -- :: Handle -> HandlePosn -> IO ()
  32     hSeek,                     -- :: Handle -> SeekMode -> Integer -> IO ()
  33     hWaitForInput,             -- :: Handle -> Int -> IO Bool
  34     hReady,                    -- :: Handle -> IO Bool
  35     hGetChar,                  -- :: Handle -> IO Char
  36     hGetLine,                  -- :: Handle -> IO [Char]
  37     hLookAhead,                -- :: Handle -> IO Char
  38     hGetContents,              -- :: Handle -> IO [Char]
  39     hPutChar,                  -- :: Handle -> Char -> IO ()
  40     hPutStr,                   -- :: Handle -> [Char] -> IO ()
  41     hPutStrLn,                 -- :: Handle -> [Char] -> IO ()
  42     hPrint,                    -- :: Show a => Handle -> a -> IO ()
  43     hIsOpen, hIsClosed,        -- :: Handle -> IO Bool
  44     hIsReadable, hIsWritable,  -- :: Handle -> IO Bool
  45     hIsSeekable,               -- :: Handle -> IO Bool
  46
  47     isAlreadyExistsError, isDoesNotExistError,  -- :: IOError -> Bool
  48     isAlreadyInUseError, isFullError,
  49     isEOFError, isIllegalOperation,
  50     isPermissionError, isUserError,
  51
  52     ioeGetErrorString,         -- :: IOError -> String
  53     ioeGetHandle,              -- :: IOError -> Maybe Handle
  54     ioeGetFileName,            -- :: IOError -> Maybe FilePath
  55
  56     try,                       -- :: IO a -> IO (Either IOError a)
  57     bracket,                   -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
  58     bracket_,                  -- :: IO a -> (a -> IO b) -> IO c -> IO c
  59
  60     -- Non-standard extension (but will hopefully become standard with 1.5) is
  61     -- to export the Prelude io functions via IO (in addition to exporting them
  62     -- from the prelude...for now.)
  63     IO,
  64     FilePath,                  -- :: String
  65     IOError,
  66     ioError,                   -- :: IOError -> IO a
  67     userError,                 -- :: String  -> IOError
  68     catch,                     -- :: IO a    -> (IOError -> IO a) -> IO a
  69     interact,                  -- :: (String -> String) -> IO ()
  70
  71     putChar,                   -- :: Char   -> IO ()
  72     putStr,                    -- :: String -> IO ()
  73     putStrLn,                  -- :: String -> IO ()
  74     print,                     -- :: Show a => a -> IO ()
  75     getChar,                   -- :: IO Char
  76     getLine,                   -- :: IO String
  77     getContents,               -- :: IO String
  78     readFile,                  -- :: FilePath -> IO String
  79     writeFile,                 -- :: FilePath -> String -> IO ()
  80     appendFile,                -- :: FilePath -> String -> IO ()
  81     readIO,                    -- :: Read a => String -> IO a
  82     readLn,                    -- :: Read a => IO a
  83
  84   ) where
  85
  86 #ifndef __HUGS__
  87 import PrelIOBase       -- Together these four Prelude modules define
  88 import PrelHandle       -- all the stuff exported by IO for the GHC version
  89 import PrelIO
  90 import PrelException
  91
  92
  93 -- The entire rest of this module is just Hugs
  94
  95 #else /* ifndef __HUGS__ */
  96
  97 import Ix(Ix)
  98 import PrelPrim ( IORef
  99                 , unsafePerformIO
 100                 , prelCleanupAfterRunAction
 101                 , copy_String_to_cstring
 102                 , primIntToChar
 103                 , primWriteCharOffAddr
 104                 , nullAddr
 105                 , newIORef
 106                 , writeIORef
 107                 , readIORef
 108                 , nh_close
 109                 , nh_errno
 110                 , nh_stdin
 111                 , nh_stdout
 112                 , nh_stderr
 113                 , nh_flush
 114                 , nh_open
 115                 , nh_free
 116                 , nh_read
 117                 , nh_write
 118                 , nh_filesize
 119                 , nh_iseof
 120                 )
 121 \end{code}
 122
 123
 124 %*********************************************************
 125 %*                                                      *
 126 \subsection{The HUGS version of IO
 127 %*                                                      *
 128 %*********************************************************
 129
 130 \begin{code}
 131 import Ix(Ix)
 132 import Monad(when)
 133
 134 unimp :: String -> a
 135 unimp s = error ("IO library: function not implemented: " ++ s)
 136
 137 type FILE_STAR = Addr
 138 type Ptr       = Addr
 139 nULL           = nullAddr
 140
 141 data Handle
 142    = Handle { name     :: FilePath,
 143               file     :: FILE_STAR,         -- C handle
 144               mut      :: IORef Handle_Mut,  -- open/closed/semiclosed
 145               mode     :: IOMode,
 146               seekable :: Bool
 147             }
 148
 149 data Handle_Mut
 150    = Handle_Mut { state :: HState
 151                 }
 152      deriving Show
 153
 154 set_state :: Handle -> HState -> IO ()
 155 set_state hdl new_state
 156    = writeIORef (mut hdl) (Handle_Mut { state = new_state })
 157 get_state :: Handle -> IO HState
 158 get_state hdl
 159    = readIORef (mut hdl) >>= \m -> return (state m)
 160
 161 mkErr :: Handle -> String -> IO a
 162 mkErr h msg
 163    = do mut <- readIORef (mut h)
 164         when (state mut /= HClosed)
 165              (nh_close (file h) >> set_state h HClosed)
 166         dummy <- nh_errno
 167         ioError (IOError msg)
 168
 169 stdin
 170    = Handle {
 171         name = "stdin",
 172         file = unsafePerformIO nh_stdin,
 173         mut  = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
 174         mode = ReadMode
 175      }
 176
 177 stdout
 178    = Handle {
 179         name = "stdout",
 180         file = unsafePerformIO nh_stdout,
 181         mut  = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
 182         mode = WriteMode
 183      }
 184
 185 stderr
 186    = Handle {
 187         name = "stderr",
 188         file = unsafePerformIO nh_stderr,
 189         mut  = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
 190         mode = WriteMode
 191      }
 192
 193
 194 instance Eq Handle where
 195    h1 == h2   = file h1 == file h2
 196
 197 instance Show Handle where
 198    showsPrec _ h = showString ("`" ++ name h ++ "'")
 199
 200 data HandlePosn
 201    = HandlePosn
 202      deriving (Eq, Show)
 203
 204
 205 data IOMode      = ReadMode | WriteMode | AppendMode | ReadWriteMode
 206                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 207
 208 data BufferMode  =  NoBuffering | LineBuffering
 209                  |  BlockBuffering (Maybe Int)
 210                     deriving (Eq, Ord, Read, Show)
 211
 212 data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
 213                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
 214
 215 data HState = HOpen | HSemiClosed | HClosed
 216               deriving (Show, Eq)
 217
 218
 219 -- A global variable holding a list of all open handles.
 220 -- Each handle is present as many times as it has been opened.
 221 -- Any given file is allowed to have _either_ one writeable handle
 222 -- or many readable handles in this list.  The list is used to
 223 -- enforce single-writer multiple reader semantics.  It also
 224 -- provides a list of handles for System.exitWith to flush and
 225 -- close.  In order not to have to put all this stuff in the
 226 -- Prelude, System.exitWith merely runs prelExitWithAction,
 227 -- which is originally Nothing, but which we set to Just ...
 228 -- once handles appear in the list.
 229
 230 allHandles :: IORef [Handle]
 231 allHandles  = unsafePerformIO (newIORef [])
 232
 233 elemWriterHandles :: FilePath -> IO Bool
 234 elemAllHandles    :: FilePath -> IO Bool
 235 addHandle         :: Handle -> IO ()
 236 delHandle         :: Handle -> IO ()
 237 cleanupHandles    :: IO ()
 238
 239 cleanupHandles
 240    = do hdls <- readIORef allHandles
 241         mapM_ cleanupHandle hdls
 242      where
 243         cleanupHandle h
 244            | mode h == ReadMode
 245            = nh_close (file h)
 246              >> nh_errno >>= \_ -> return ()
 247            | otherwise
 248            = nh_flush (file h) >> nh_close (file h)
 249              >> nh_errno >>= \_ -> return ()
 250
 251 elemWriterHandles fname
 252    = do hdls <- readIORef allHandles
 253         let hdls_w = filter ((/= ReadMode).mode) hdls
 254         return (fname `elem` (map name hdls_w))
 255
 256 elemAllHandles fname
 257    = do hdls <- readIORef allHandles
 258         return (fname `elem` (map name hdls))
 259
 260 addHandle hdl
 261    = do cleanup_action <- readIORef prelCleanupAfterRunAction
 262         case cleanup_action of
 263            Nothing
 264               -> writeIORef prelCleanupAfterRunAction (Just cleanupHandles)
 265            Just xx
 266               -> return ()
 267         hdls <- readIORef allHandles
 268         writeIORef allHandles (hdl : hdls)
 269
 270 delHandle hdl
 271    = do hdls <- readIORef allHandles
 272         let hdls' = takeWhile (/= hdl) hdls
 273                     ++ drop 1 (dropWhile (/= hdl) hdls)
 274         writeIORef allHandles hdls'
 275
 276
 277
 278 openFile :: FilePath -> IOMode -> IO Handle
 279 openFile f mode
 280
 281    | null f
 282    =  (ioError.IOError) "openFile: empty file name"
 283
 284    | mode == ReadMode
 285    = do not_ok <- elemWriterHandles f
 286         if    not_ok
 287          then (ioError.IOError)
 288                  ("openFile: `" ++ f ++ "' in " ++ show mode
 289                   ++ ": is already open for writing")
 290          else openFile_main f mode
 291
 292    | mode /= ReadMode
 293    = do not_ok <- elemAllHandles f
 294         if    not_ok
 295          then (ioError.IOError)
 296                  ("openFile: `" ++ f ++ "' in " ++ show mode
 297                   ++ ": is already open for reading or writing")
 298          else openFile_main f mode
 299
 300    | otherwise
 301    = openFile_main f mode
 302
 303 openFile_main f mode
 304    = copy_String_to_cstring f >>= \nameptr ->
 305      nh_open nameptr (mode2num mode) >>= \fh ->
 306      nh_free nameptr >>
 307      if   fh == nULL
 308      then (ioError.IOError)
 309              ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode)
 310      else do r   <- newIORef (Handle_Mut { state = HOpen })
 311              let hdl = Handle { name = f, file = fh,
 312                                 mut  = r, mode = mode }
 313              addHandle hdl
 314              return hdl
 315      where
 316         mode2num :: IOMode -> Int
 317         mode2num ReadMode   = 0
 318         mode2num WriteMode  = 1
 319         mode2num AppendMode = 2
 320         mode2num ReadWriteMode
 321            = error
 322                 ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported")
 323
 324 hClose :: Handle -> IO ()
 325 hClose h
 326    = do mut <- readIORef (mut h)
 327         if    state mut == HClosed
 328          then mkErr h
 329                  ("hClose on closed handle " ++ show h)
 330          else
 331          do set_state h HClosed
 332             delHandle h
 333             nh_close (file h)
 334             err <- nh_errno
 335             if    err == 0
 336              then return ()
 337              else mkErr h
 338                      ("hClose: error closing " ++ name h)
 339
 340 hGetContents :: Handle -> IO String
 341 hGetContents h
 342    | mode h /= ReadMode
 343    = mkErr h ("hGetContents on non-ReadMode handle " ++ show h)
 344    | otherwise
 345    = do mut <- readIORef (mut h)
 346         if    state mut /= HOpen
 347          then mkErr h
 348                  ("hGetContents on closed/semiclosed handle " ++ show h)
 349          else
 350          do set_state h HSemiClosed
 351             read_all (file h)
 352             where
 353                read_all f
 354                   = nh_read f >>= \ci ->
 355                     if   ci == -1
 356                     then return []
 357                     else read_all f >>= \rest ->
 358                          return ((primIntToChar ci):rest)
 359
 360 hPutStr :: Handle -> String -> IO ()
 361 hPutStr h s
 362    | mode h == ReadMode
 363    = mkErr h ("hPutStr on ReadMode handle " ++ show h)
 364    | otherwise
 365    = do mut <- readIORef (mut h)
 366         if    state mut /= HOpen
 367          then mkErr h
 368                  ("hPutStr on closed/semiclosed handle " ++ show h)
 369          else write_all (file h) s
 370               where
 371                  write_all f []
 372                     = return ()
 373                  write_all f (c:cs)
 374                     = nh_write f c >> write_all f cs
 375
 376 hFileSize :: Handle -> IO Integer
 377 hFileSize h
 378    = do sz <- nh_filesize (file h)
 379         er <- nh_errno
 380         if    er == 0
 381          then return (fromIntegral sz)
 382          else mkErr h ("hFileSize on " ++ show h)
 383
 384 hIsEOF :: Handle -> IO Bool
 385 hIsEOF h
 386    = do iseof <- nh_iseof (file h)
 387         er    <- nh_errno
 388         if    er == 0
 389          then return (iseof /= 0)
 390          else mkErr h ("hIsEOF on " ++ show h)
 391
 392 isEOF :: IO Bool
 393 isEOF = hIsEOF stdin
 394
 395 hSetBuffering         :: Handle  -> BufferMode -> IO ()
 396 hSetBuffering          = unimp "IO.hSetBuffering"
 397 hGetBuffering         :: Handle  -> IO BufferMode
 398 hGetBuffering          = unimp "IO.hGetBuffering"
 399
 400 hFlush :: Handle -> IO ()
 401 hFlush h
 402    = do mut <- readIORef (mut h)
 403         if    state mut /= HOpen
 404          then mkErr h
 405                  ("hFlush on closed/semiclosed file " ++ name h)
 406          else nh_flush (file h)
 407
 408 hGetPosn              :: Handle -> IO HandlePosn
 409 hGetPosn               = unimp "IO.hGetPosn"
 410 hSetPosn              :: HandlePosn -> IO ()
 411 hSetPosn               = unimp "IO.hSetPosn"
 412 hSeek                 :: Handle -> SeekMode -> Integer -> IO ()
 413 hSeek                  = unimp "IO.hSeek"
 414 hWaitForInput         :: Handle -> Int -> IO Bool
 415 hWaitForInput          = unimp "hWaitForInput"
 416 hReady                :: Handle -> IO Bool
 417 hReady h               = unimp "hReady" -- hWaitForInput h 0
 418
 419 hGetChar    :: Handle -> IO Char
 420 hGetChar h
 421    = nh_read (file h) >>= \ci ->
 422      return (primIntToChar ci)
 423
 424 hGetLine              :: Handle -> IO String
 425 hGetLine h             = do c <- hGetChar h
 426                             if c=='\n' then return ""
 427                               else do cs <- hGetLine h
 428                                       return (c:cs)
 429
 430 hLookAhead            :: Handle -> IO Char
 431 hLookAhead             = unimp "IO.hLookAhead"
 432
 433
 434 hPutChar              :: Handle -> Char -> IO ()
 435 hPutChar h c           = hPutStr h [c]
 436
 437 hPutStrLn             :: Handle -> String -> IO ()
 438 hPutStrLn h s          = do { hPutStr h s; hPutChar h '\n' }
 439
 440 hPrint                :: Show a => Handle -> a -> IO ()
 441 hPrint h               = hPutStrLn h . show
 442
 443 hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
 444 hIsOpen h              = do { s <- get_state h; return (s == HOpen) }
 445 hIsClosed h            = do { s <- get_state h; return (s == HClosed) }
 446 hIsReadable h          = return (mode h == ReadMode)
 447 hIsWritable h          = return (mode h `elem` [WriteMode, AppendMode])
 448
 449 hIsSeekable           :: Handle -> IO Bool
 450 hIsSeekable            = unimp "IO.hIsSeekable"
 451
 452 isIllegalOperation,
 453           isAlreadyExistsError,
 454           isDoesNotExistError,
 455           isAlreadyInUseError,
 456           isFullError,
 457           isEOFError,
 458           isPermissionError,
 459           isUserError        :: IOError -> Bool
 460
 461 isIllegalOperation    = unimp "IO.isIllegalOperation"
 462 isAlreadyExistsError  = unimp "IO.isAlreadyExistsError"
 463 isDoesNotExistError   = unimp "IO.isDoesNotExistError"
 464 isAlreadyInUseError   = unimp "IO.isAlreadyInUseError"
 465 isFullError           = unimp "IO.isFullError"
 466 isEOFError            = unimp "IO.isEOFError"
 467 isPermissionError     = unimp "IO.isPermissionError"
 468 isUserError           = unimp "IO.isUserError"
 469
 470
 471 ioeGetErrorString :: IOError -> String
 472 ioeGetErrorString = unimp "IO.ioeGetErrorString"
 473 ioeGetHandle      :: IOError -> Maybe Handle
 474 ioeGetHandle      = unimp "IO.ioeGetHandle"
 475 ioeGetFileName    :: IOError -> Maybe FilePath
 476 ioeGetFileName    = unimp "IO.ioeGetFileName"
 477
 478 try       :: IO a -> IO (Either IOError a)
 479 try p      = catch (p >>= (return . Right)) (return . Left)
 480
 481 bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
 482 bracket before after m = do
 483         x  <- before
 484         rs <- try (m x)
 485         after x
 486         case rs of
 487            Right r -> return r
 488            Left  e -> ioError e
 489
 490 -- variant of the above where middle computation doesn't want x
 491 bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
 492 bracket_ before after m = do
 493          x  <- before
 494          rs <- try m
 495          after x
 496          case rs of
 497             Right r -> return r
 498             Left  e -> ioError e
 499
 500 -- TODO: Hugs/slurpFile
 501 slurpFile = unimp "IO.slurpFile"
 502 \end{code}
 503
 504 #endif /* #ifndef __HUGS__ */