path: root/ghc/lib/std/PrelIOBase.lhs

% -----------------------------------------------------------------------------
% $Id: PrelIOBase.lhs,v 1.11 1999/06/12 16:17:26 keithw Exp $
% 
% (c) The AQUA Project, Glasgow University, 1994-1998
%

\section[PrelIOBase]{Module @PrelIOBase@}

Definitions for the @IO@ monad and its friends.  Everything is exported
concretely; the @IO@ module itself exports abstractly.

\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
#include "cbits/error.h"

#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelIOBase where

import {-# SOURCE #-} PrelErr ( error )

import PrelST
import PrelBase
import {-# SOURCE #-} PrelException ( ioError )
import PrelST	  ( ST(..), STret(..) )
import PrelMaybe  ( Maybe(..) )
import PrelAddr	  ( Addr(..), nullAddr )
import PrelPack   ( unpackCString )
import PrelShow

#if !defined(__CONCURRENT_HASKELL__)
import PrelArr	  ( MutableVar, readVar )
#endif
#endif

#ifdef __HUGS__
#define cat2(x,y)  x##y
#define CCALL(fun) cat2(prim_,fun)
#define __CONCURRENT_HASKELL__
#define stToIO id
#define unpackCString primUnpackString
#else
#define CCALL(fun) _ccall_ fun
#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
#endif

#ifndef __PARALLEL_HASKELL__
#define FILE_OBJECT	    ForeignObj
#else
#define FILE_OBJECT	    Addr
#endif
\end{code}

%*********************************************************
%*							*
\subsection{The @IO@ monad}
%*							*
%*********************************************************

The IO Monad is just an instance of the ST monad, where the state is
the real world.  We use the exception mechanism (in PrelException) to
implement IO exceptions.

\begin{code}
#ifndef __HUGS__
newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))

unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
unIO (IO a) = a

instance  Functor IO where
   fmap f x = x >>= (return . f)

instance  Monad IO  where
    {-# INLINE return #-}
    {-# INLINE (>>)   #-}
    {-# INLINE (>>=)  #-}
    m >> k      =  m >>= \ _ -> k
    return x	= IO $ \ s -> (# s, x #)

    m >>= k     = bindIO m k
    fail s	= error s -- not ioError?

    -- not required but worth having around
fixIO 		:: (a -> IO a) -> IO a
fixIO m         = stToIO (fixST (ioToST . m))

liftIO :: IO a -> State# RealWorld -> STret RealWorld a
liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r

bindIO :: IO a -> (a -> IO b) -> IO b
bindIO (IO m) k = IO ( \ s ->
  case m s of 
    (# new_s, a #) -> unIO (k a) new_s
  )

#endif
\end{code}

%*********************************************************
%*							*
\subsection{Coercions to @ST@}
%*							*
%*********************************************************

\begin{code}
#ifdef __HUGS__
/* Hugs doesn't distinguish these types so no coercion required) */
#else
stToIO	      :: ST RealWorld a -> IO a
stToIO (ST m) = (IO m)

ioToST	      :: IO a -> ST RealWorld a
ioToST (IO m) = (ST m)
#endif
\end{code}

%*********************************************************
%*							*
\subsection{Unsafe @IO@ operations}
%*							*
%*********************************************************

\begin{code}
#ifndef __HUGS__
{-# NOINLINE unsafePerformIO #-}
unsafePerformIO	:: IO a -> a
unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r

unsafeInterleaveIO :: IO a -> IO a
unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST
#endif
\end{code}

%*********************************************************
%*							*
\subsection{Type @IOError@}
%*							*
%*********************************************************

A value @IOError@ encode errors occurred in the @IO@ monad.
An @IOError@ records a more specific error type, a descriptive
string and maybe the handle that was used when the error was
flagged.

\begin{code}
data IOError 
 = IOError 
     (Maybe Handle)  -- the handle used by the action flagging the
		     -- the error.
     IOErrorType     -- what it was.
     String	     -- location
     String          -- error type specific information.


data IOErrorType
  = AlreadyExists        | HardwareFault
  | IllegalOperation     | InappropriateType
  | Interrupted          | InvalidArgument
  | NoSuchThing          | OtherError
  | PermissionDenied     | ProtocolError
  | ResourceBusy         | ResourceExhausted
  | ResourceVanished     | SystemError
  | TimeExpired          | UnsatisfiedConstraints
  | UnsupportedOperation | UserError
  | EOF
#ifdef _WIN32
  | ComError Int           -- HRESULT
#endif
  deriving (Eq)

instance Show IOErrorType where
  showsPrec _ e =
    showString $
    case e of
      AlreadyExists	-> "already exists"
      HardwareFault	-> "hardware fault"
      IllegalOperation	-> "illegal operation"
      InappropriateType -> "inappropriate type"
      Interrupted       -> "interrupted"
      InvalidArgument   -> "invalid argument"
      NoSuchThing       -> "does not exist"
      OtherError        -> "failed"
      PermissionDenied  -> "permission denied"
      ProtocolError     -> "protocol error"
      ResourceBusy      -> "resource busy"
      ResourceExhausted -> "resource exhausted"
      ResourceVanished  -> "resource vanished"
      SystemError	-> "system error"
      TimeExpired       -> "timeout"
      UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
      UserError         -> "failed"
      UnsupportedOperation -> "unsupported operation"
      EOF		-> "end of file"
#ifdef _WIN32
      ComError _	-> "COM error"
#endif



userError       :: String  -> IOError
userError str	=  IOError Nothing UserError "" str
\end{code}

Predicates on IOError; little effort made on these so far...

\begin{code}

isAlreadyExistsError :: IOError -> Bool
isAlreadyExistsError (IOError _ AlreadyExists _ _) = True
isAlreadyExistsError _		                   = False

isAlreadyInUseError :: IOError -> Bool
isAlreadyInUseError (IOError _ ResourceBusy _ _) = True
isAlreadyInUseError _		                 = False

isFullError :: IOError -> Bool
isFullError (IOError _ ResourceExhausted _ _) = True
isFullError _			              = False

isEOFError :: IOError -> Bool
isEOFError (IOError _ EOF _ _) = True
isEOFError _                   = False

isIllegalOperation :: IOError -> Bool
isIllegalOperation (IOError _ IllegalOperation _ _) = True
isIllegalOperation _			            = False

isPermissionError :: IOError -> Bool
isPermissionError (IOError _ PermissionDenied _ _) = True
isPermissionError _			           = False

isDoesNotExistError :: IOError -> Bool
isDoesNotExistError (IOError _ NoSuchThing _ _) = True
isDoesNotExistError _                           = False

isUserError :: IOError -> Bool
isUserError (IOError _ UserError _ _) = True
isUserError _		              = False
\end{code}

Showing @IOError@s

\begin{code}
#ifdef __HUGS__
-- For now we give a fairly uninformative error message which just happens to
-- be like the ones that Hugs used to give.
instance Show IOError where
    showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
#else
instance Show IOError where
    showsPrec p (IOError hdl iot loc s) =
      showsPrec p iot .
      showChar '\n' .
      (case loc of
         "" -> id
	 _  -> showString "Action: " . showString loc . showChar '\n') .
      showHdl .
      (case s of
	 "" -> id
	 _  -> showString "Reason: " . showString s)
     where
      showHdl = 
       case hdl of
        Nothing -> id
	Just h  -> showString "Handle: " . showsPrec p h

#endif
\end{code}

The @String@ part of an @IOError@ is platform-dependent.  However, to
provide a uniform mechanism for distinguishing among errors within
these broad categories, each platform-specific standard shall specify
the exact strings to be used for particular errors.  For errors not
explicitly mentioned in the standard, any descriptive string may be
used.

\begin{code}
constructErrorAndFail :: String -> IO a
constructErrorAndFail call_site
  = constructError call_site >>= \ io_error ->
    ioError io_error

constructErrorAndFailWithInfo :: String -> String -> IO a
constructErrorAndFailWithInfo call_site reason
  = constructErrorMsg call_site (Just reason) >>= \ io_error ->
    ioError io_error

\end{code}

This doesn't seem to be documented/spelled out anywhere,
so here goes: (SOF)

The implementation of the IO prelude uses various C stubs
to do the actual interaction with the OS. The bandwidth
\tr{C<->Haskell} is somewhat limited, so the general strategy
for flaggging any errors (apart from possibly using the
return code of the external call), is to set the @ghc_errtype@
to a value that is one of the \tr{#define}s in @includes/error.h@.
@ghc_errstr@ holds a character string providing error-specific
information. Error constructing functions will then reach out
and grab these values when generating

\begin{code}
constructError	      :: String -> IO IOError
constructError call_site = constructErrorMsg call_site Nothing

constructErrorMsg	      :: String -> Maybe String -> IO IOError
constructErrorMsg call_site reason =
 CCALL(getErrType__)            >>= \ errtype ->
 CCALL(getErrStr__)             >>= \ str ->
 let
  iot =
   case (errtype::Int) of
     ERR_ALREADYEXISTS	         -> AlreadyExists
     ERR_HARDWAREFAULT	         -> HardwareFault
     ERR_ILLEGALOPERATION	 -> IllegalOperation
     ERR_INAPPROPRIATETYPE	 -> InappropriateType
     ERR_INTERRUPTED	         -> Interrupted
     ERR_INVALIDARGUMENT	 -> InvalidArgument
     ERR_NOSUCHTHING	         -> NoSuchThing
     ERR_OTHERERROR		 -> OtherError
     ERR_PERMISSIONDENIED	 -> PermissionDenied
     ERR_PROTOCOLERROR	         -> ProtocolError
     ERR_RESOURCEBUSY	         -> ResourceBusy
     ERR_RESOURCEEXHAUSTED	 -> ResourceExhausted
     ERR_RESOURCEVANISHED	 -> ResourceVanished
     ERR_SYSTEMERROR	         -> SystemError
     ERR_TIMEEXPIRED	         -> TimeExpired
     ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints
     ERR_UNSUPPORTEDOPERATION   -> UnsupportedOperation
     ERR_EOF		         -> EOF
     _			         -> OtherError

  msg = 
   unpackCString str ++
   (case iot of
     OtherError -> "(error code: " ++ show errtype ++ ")"
     _ -> "") ++
   (case reason of
      Nothing -> ""
      Just m  -> ' ':m)
 in
 return (IOError Nothing iot call_site msg)
\end{code}

File names are specified using @FilePath@, a OS-dependent
string that (hopefully, I guess) maps to an accessible file/object.

\begin{code}
type FilePath = String
\end{code}

%*********************************************************
%*							*
\subsection{Types @Handle@, @Handle__@}
%*							*
%*********************************************************

The type for @Handle@ is defined rather than in @IOHandle@
module, as the @IOError@ type uses it..all operations over
a handles reside in @IOHandle@.

\begin{code}

#ifndef __HUGS__
{-
 Sigh, the MVar ops in ConcBase depend on IO, the IO
 representation here depend on MVars for handles (when
 compiling in a concurrent way). Break the cycle by having
 the definition of MVars go here:

-}
data MVar a = MVar (MVar# RealWorld a)

{-
  Double sigh - ForeignObj is needed here too to break a cycle.
-}
data ForeignObj = ForeignObj ForeignObj#   -- another one
instance CCallable ForeignObj
instance CCallable ForeignObj#
#endif /* ndef __HUGS__ */

#if defined(__CONCURRENT_HASKELL__)
newtype Handle = Handle (MVar Handle__)
#else
newtype Handle = Handle (MutableVar RealWorld Handle__)
#endif

{-
  A Handle is represented by (a reference to) a record 
  containing the state of the I/O port/device. We record
  the following pieces of info:

    * type (read,write,closed etc.)
    * pointer to the external file object.
    * buffering mode 
    * user-friendly name (usually the
      FilePath used when IO.openFile was called)

Note: when a Handle is garbage collected, we want to flush its buffer
and close the OS file handle, so as to free up a (precious) resource.
-}
data Handle__
  = Handle__ {
      haFO__	      :: FILE_OBJECT,
      haType__        :: Handle__Type,
      haBufferMode__  :: BufferMode,
      haFilePath__    :: FilePath
    }      

{-
  Internally, we classify handles as being one
  of the following:
-}
data Handle__Type
 = ErrorHandle  IOError
 | ClosedHandle
 | SemiClosedHandle
 | ReadHandle
 | WriteHandle
 | AppendHandle
 | ReadWriteHandle


-- handle types are 'show'ed when printing error msgs, so
-- we provide a more user-friendly Show instance for it
-- than the derived one.
instance Show Handle__Type where
  showsPrec p t =
    case t of
      ErrorHandle iot   -> showString "error " . showsPrec p iot
      ClosedHandle      -> showString "closed"
      SemiClosedHandle  -> showString "semi-closed"
      ReadHandle        -> showString "readable"
      WriteHandle       -> showString "writeable"
      AppendHandle      -> showString "writeable (append)"
      ReadWriteHandle   -> showString "read-writeable"

instance Show Handle where 
  showsPrec p (Handle h) = 
    let
#if defined(__CONCURRENT_HASKELL__)
#ifdef __HUGS__
     hdl_ = unsafePerformIO (primTakeMVar h)
#else
     -- (Big) SIGH: unfolded defn of takeMVar to avoid
     -- an (oh-so) unfortunate module loop with PrelConc.
     hdl_ = unsafePerformIO (IO $ \ s# ->
	     case h               of { MVar h# ->
	     case takeMVar# h# s# of { (# s2# , r #) -> 
		    (# s2#, r #) }})
#endif
#else
     hdl_ = unsafePerformIO (stToIO (readVar h))
#endif
    in
    showChar '{' . 
    showHdl (haType__ hdl_) 
	    (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' .
	     showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' .
	     showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" )
   where
    showHdl :: Handle__Type -> ShowS -> ShowS
    showHdl ht cont = 
       case ht of
        ClosedHandle  -> showsPrec p ht . showString "}\n"
        ErrorHandle _ -> showsPrec p ht . showString "}\n"
	_ -> cont
       
    showBufMode :: FILE_OBJECT -> BufferMode -> ShowS
    showBufMode fo bmo =
      case bmo of
        NoBuffering   -> showString "none"
	LineBuffering -> showString "line"
	BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
	BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
      where
       def :: Int 
       def = unsafePerformIO (CCALL(getBufSize) fo)

mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
mkBuffer__ fo sz_in_bytes = do
 chunk <- 
  case sz_in_bytes of
    0 -> return nullAddr  -- this has the effect of overwriting the pointer to the old buffer.
    _ -> do
     chunk <- CCALL(allocMemory__) sz_in_bytes
     if chunk == nullAddr
      then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
      else return chunk
 CCALL(setBuf) fo chunk sz_in_bytes

\end{code}

%*********************************************************
%*							*
\subsection[BufferMode]{Buffering modes}
%*							*
%*********************************************************

Three kinds of buffering are supported: line-buffering, 
block-buffering or no-buffering.  These modes have the following
effects. For output, items are written out from the internal
buffer according to the buffer mode:

\begin{itemize}
\item[line-buffering]  the entire output buffer is written
out whenever a newline is output, the output buffer overflows, 
a flush is issued, or the handle is closed.

\item[block-buffering] the entire output buffer is written out whenever 
it overflows, a flush is issued, or the handle
is closed.

\item[no-buffering] output is written immediately, and never stored
in the output buffer.
\end{itemize}

The output buffer is emptied as soon as it has been written out.

Similarly, input occurs according to the buffer mode for handle {\em hdl}.
\begin{itemize}
\item[line-buffering] when the input buffer for {\em hdl} is not empty,
the next item is obtained from the buffer;
otherwise, when the input buffer is empty,
characters up to and including the next newline
character are read into the buffer.  No characters
are available until the newline character is
available.
\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
the next block of data is read into this buffer.
\item[no-buffering] the next input item is read and returned.
\end{itemize}

For most implementations, physical files will normally be block-buffered 
and terminals will normally be line-buffered. (the IO interface provides
operations for changing the default buffering of a handle tho.)

\begin{code}
data BufferMode  
 = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
   deriving (Eq, Ord, Show)
   {- Read instance defined in IO. -}

\end{code}