GetContents.hs

{-# LANGUAGE MagicHash, UnboxedTuples #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  System.IO.Unsafe.GetContents
-- Copyright   :  (c) The University of Glasgow, 1992-2001
-- License     :  see GHC sources in libraries/base/LICENSE
-- 
-- Maintainer  :  Nicolas Pouillard <nicolas.pouillard@gmail.com>
-- Stability   :  internal
-- Portability :  non-portable
--
-- This code is extracted from GHC sources and changed to no longer
-- discards I\/O errors.
-----------------------------------------------------------------------------

module System.IO.Unsafe.GetContents
  (unsafeHGetContents
  ,lazyRead)
where

import Prelude hiding (catch)
import Control.Exception.Extensible (catch)
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.IORef
import GHC.Base
import GHC.Handle
import GHC.IOBase (Buffer(..), Handle__(..), Handle, RawBuffer, IO(IO), FD
                  ,BufferMode(..), HandleType(..), IOException(..)
                  ,IOErrorType(..), ioException, bufferEmpty)


-- | 'unsafeHGetContents' is pretty much like 'hGetContents' but does not
-- discards I\/O errors get during the lazy reading.
--
-- This code was copy/pasted from the GHC version of hGetContents.
unsafeHGetContents :: Handle -> IO String
unsafeHGetContents handle = 
    withHandle "unsafeHGetContents" handle $ \handle_ ->
    case haType handle_ of 
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_closedHandle
      AppendHandle         -> ioe_notReadable
      WriteHandle          -> ioe_notReadable
      _ -> do xs <- lazyRead handle
              return (handle_{ haType=SemiClosedHandle}, xs )

-- Note that someone may close the semi-closed handle (or change its
-- buffering), so each time these lazy read functions are pulled on,
-- they have to check whether the handle has indeed been closed.

lazyRead :: Handle -> IO String
lazyRead handle = 
   unsafeInterleaveIO $
        withHandle "lazyRead" handle $ \ handle_ -> do
        case haType handle_ of
          -- here we do not silently returns an empty stream on a closed handle
          -- ClosedHandle     -> return (handle_, "")
          SemiClosedHandle -> lazyRead' handle handle_
          _ -> ioException 
                  (IOError (Just handle) IllegalOperation "lazyRead"
                        "illegal handle type" Nothing) -- Nothing)

lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char])
lazyRead' h handle_ = do
  let ref = haBuffer handle_
      fd  = haFD handle_

  -- even a NoBuffering handle can have a char in the buffer... 
  -- (see hLookAhead)
  buf <- readIORef ref
  if not (bufferEmpty buf)
        then lazyReadHaveBuffer h handle_ fd ref buf
        else do

  case haBufferMode handle_ of
     NoBuffering      -> do
        -- make use of the minimal buffer we already have
        let raw = bufBuf buf
        r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
        if r == 0
           then do (handle_', _) <- hClose_help handle_ 
                   return (handle_', "")
           else do (c,_) <- readCharFromBuffer raw 0
                   rest <- lazyRead h
                   return (handle_, c : rest)

     LineBuffering    -> lazyReadBuffered h handle_ fd ref buf
     BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf

-- we never want to block during the read, so we call fillReadBuffer with
-- is_line==True, which tells it to "just read what there is".
lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer
                 -> IO (Handle__, [Char])
lazyReadBuffered h handle_ fd ref buf = -- do
   catch 
        (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
            lazyReadHaveBuffer h handle_ fd ref buf'
        )
        (\IOError{ioe_type=EOF} -> do (handle_', _) <- hClose_help handle_
                                      return (handle_', "")
        )
-- Here we do not discard I/O errors, only EOF is caught.
{-
        -- all I/O errors are discarded.  Additionally, we close the handle.
        (\(_ :: SomeException) -> do (handle_', _) <- hClose_help handle_
                                     return (handle_', "")
        )
-}

lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char])
lazyReadHaveBuffer h handle_ _ ref buf = do
   more <- lazyRead h
   writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
   s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
   return (handle_, s)


unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
unpackAcc _   _      0        acc  = return acc
unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s
   where
    unpackRB acc i s
     | i <# r  = (# s, acc #)
     | otherwise = 
          case readCharArray# buf i s of
          (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'