ghc/lib/ghc/IOBase.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[IOBase]{Module @IOBase@}
   6
   7 Definitions for the @IO@ monad and its friends.  Everything is exported
   8 concretely; the @IO@ module itself exports abstractly.
   9
  10 \begin{code}
  11 #include "error.h"
  12
  13 {-# OPTIONS -fno-implicit-prelude #-}
  14
  15 module IOBase where
  16
  17 import STBase
  18 import PrelTup
  19 import Foreign
  20 import PackedString     ( unpackCString )
  21 import PrelBase
  22 import GHC
  23
  24 infixr 1 `thenIO_Prim`
  25 \end{code}
  26
  27 %*********************************************************
  28 %*                                                      *
  29 \subsection{The @IO@ monad}
  30 %*                                                      *
  31 %*********************************************************
  32
  33 \begin{code}
  34 newtype IO a = IO (PrimIO (Either IOError a))
  35
  36 instance  Functor IO where
  37    map f x = x >>= (return . f)
  38
  39 instance  Monad IO  where
  40 {-      No inlining for now... until we can inline some of the
  41         imports, like $, these functions are pretty big.
  42     {-# INLINE return #-}
  43     {-# INLINE (>>)   #-}
  44     {-# INLINE (>>=)  #-}
  45 -}
  46     m >> k      =  m >>= \ _ -> k
  47     return x    = IO $ ST $ \ s@(S# _) -> (Right x, s)
  48
  49     (IO (ST m)) >>= k
  50       = IO $ ST $ \ s ->
  51         let  (r, new_s) = m s  in
  52         case r of
  53           Left err -> (Left err, new_s)
  54           Right  x -> case (k x) of { IO (ST k2) ->
  55                       k2 new_s }
  56
  57 fixIO :: (a -> IO a) -> IO a
  58     -- not required but worth having around
  59
  60 fixIO k = IO $ ST $ \ s ->
  61     let
  62         (IO (ST k_loop)) = k loop
  63         result           = k_loop s
  64         (Right loop, _)  = result
  65     in
  66     result
  67
  68 fail            :: IOError -> IO a
  69 fail err        =  IO $ ST $ \ s -> (Left err, s)
  70
  71 userError       :: String  -> IOError
  72 userError str   =  UserError str
  73
  74 catch           :: IO a    -> (IOError -> IO a) -> IO a
  75 catch (IO (ST m)) k  = IO $ ST $ \ s ->
  76   case (m s) of { (r, new_s) ->
  77   case r of
  78     Right  _ -> (r, new_s)
  79     Left err -> case (k err) of { IO (ST k_err) ->
  80                 (k_err new_s) }}
  81
  82 instance  Show (IO a)  where
  83     showsPrec p f  = showString "<<IO action>>"
  84     showList       = showList__ (showsPrec 0)
  85 \end{code}
  86
  87 %*********************************************************
  88 %*                                                      *
  89 \subsection{Coercions to @ST@ and @PrimIO@}
  90 %*                                                      *
  91 %*********************************************************
  92
  93 \begin{code}
  94 stToIO     :: ST RealWorld a -> IO a
  95 primIOToIO :: PrimIO a       -> IO a
  96 ioToST     :: IO a -> ST RealWorld a
  97 ioToPrimIO :: IO a -> PrimIO       a
  98
  99 primIOToIO = stToIO -- for backwards compatibility
 100 ioToPrimIO = ioToST
 101
 102 stToIO (ST m) = IO $ ST $ \ s ->
 103     case (m s) of { (r, new_s) ->
 104     (Right r, new_s) }
 105
 106 ioToST (IO (ST io)) = ST $ \ s ->
 107     case (io s) of { (r, new_s) ->
 108     case r of
 109       Right a -> (a, new_s)
 110       Left  e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
 111     }
 112 \end{code}
 113
 114 @thenIO_Prim@ is a useful little number for doing _ccall_s in IO-land:
 115
 116 \begin{code}
 117 thenIO_Prim :: PrimIO a -> (a -> IO b) -> IO b
 118 {-# INLINE thenIO_Prim   #-}
 119
 120 thenIO_Prim (ST m) k = IO $ ST $ \ s ->
 121     case (m s)     of { (m_res, new_s)    ->
 122     case (k m_res) of { (IO (ST k_m_res)) ->
 123     k_m_res new_s }}
 124 \end{code}
 125
 126
 127 %*********************************************************
 128 %*                                                      *
 129 \subsection{Error/trace-ish functions}
 130 %*                                                      *
 131 %*********************************************************
 132
 133 \begin{code}
 134 errorIO :: PrimIO () -> a
 135
 136 errorIO (ST io)
 137   = case (errorIO# io) of
 138       _ -> bottom
 139   where
 140     bottom = bottom -- Never evaluated
 141
 142 -- error stops execution and displays an error message
 143 error :: String -> a
 144 error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
 145
 146 error__ :: (Addr{-FILE *-} -> PrimIO ()) -> String -> a
 147
 148 error__ msg_hdr s
 149 #ifdef __PARALLEL_HASKELL__
 150   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
 151              _ccall_ fflush sTDERR      >>
 152              fputs sTDERR s             >>
 153              _ccall_ fflush sTDERR      >>
 154              _ccall_ stg_exit (1::Int)
 155             )
 156 #else
 157   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
 158              _ccall_ fflush sTDERR      >>
 159              fputs sTDERR s             >>
 160              _ccall_ fflush sTDERR      >>
 161              _ccall_ getErrorHandler    >>= \ errorHandler ->
 162              if errorHandler == (-1::Int) then
 163                 _ccall_ stg_exit (1::Int)
 164              else
 165                 _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
 166                                                 >>= \ osptr ->
 167                 _ccall_ decrementErrorCount     >>= \ () ->
 168                 deRefStablePtr osptr            >>= \ oact ->
 169                 oact
 170             )
 171 #endif {- !parallel -}
 172   where
 173     sTDERR = (``stderr'' :: Addr)
 174 \end{code}
 175
 176 \begin{code}
 177 {-# GENERATE_SPECS _trace a #-}
 178 trace :: String -> a -> a
 179
 180 trace string expr
 181   = unsafePerformPrimIO (
 182         ((_ccall_ PreTraceHook sTDERR{-msg-}):: PrimIO ())  >>
 183         fputs sTDERR string                                 >>
 184         ((_ccall_ PostTraceHook sTDERR{-msg-}):: PrimIO ()) >>
 185         returnPrimIO expr )
 186   where
 187     sTDERR = (``stderr'' :: Addr)
 188 \end{code}
 189
 190
 191 %*********************************************************
 192 %*                                                      *
 193 \subsection{Utility functions}
 194 %*                                                      *
 195 %*********************************************************
 196
 197 The construct $try comp$ exposes errors which occur within a
 198 computation, and which are not fully handled.  It always succeeds.
 199 This one didn't make it into the 1.3 defn
 200
 201 \begin{code}
 202 tryIO :: IO a -> IO (Either IOError a)
 203 tryIO p = catch (p >>= (return . Right)) (return . Left)
 204 \end{code}
 205
 206 I'm not sure why this little function is here...
 207
 208 \begin{code}
 209 fputs :: Addr{-FILE*-} -> String -> PrimIO Bool
 210
 211 fputs stream [] = return True
 212
 213 fputs stream (c : cs)
 214   = _ccall_ stg_putc c stream >> -- stg_putc expands to putc
 215     fputs stream cs              -- (just does some casting stream)
 216 \end{code}
 217
 218
 219 %*********************************************************
 220 %*                                                      *
 221 \subsection{Type @IOError@}
 222 %*                                                      *
 223 %*********************************************************
 224
 225 \begin{code}
 226 data IOError
 227   = AlreadyExists               String
 228   | HardwareFault               String
 229   | IllegalOperation            String
 230   | InappropriateType           String
 231   | Interrupted                 String
 232   | InvalidArgument             String
 233   | NoSuchThing                 String
 234   | OtherError                  String
 235   | PermissionDenied            String
 236   | ProtocolError               String
 237   | ResourceBusy                String
 238   | ResourceExhausted           String
 239   | ResourceVanished            String
 240   | SystemError                 String
 241   | TimeExpired                 String
 242   | UnsatisfiedConstraints      String
 243   | UnsupportedOperation        String
 244   | UserError                   String
 245   | EOF
 246
 247 instance Eq IOError where
 248     -- I don't know what the (pointless) idea is here,
 249     -- presumably just compare them by their tags (WDP)
 250     a == b = tag a == tag b
 251       where
 252         tag (AlreadyExists _)           = (1::Int)
 253         tag (HardwareFault _)           = 2
 254         tag (IllegalOperation _)        = 3
 255         tag (InappropriateType _)       = 4
 256         tag (Interrupted _)             = 5
 257         tag (InvalidArgument _)         = 6
 258         tag (NoSuchThing _)             = 7
 259         tag (OtherError _)              = 8
 260         tag (PermissionDenied _)        = 9
 261         tag (ProtocolError _)           = 10
 262         tag (ResourceBusy _)            = 11
 263         tag (ResourceExhausted _)       = 12
 264         tag (ResourceVanished _)        = 13
 265         tag (SystemError _)             = 14
 266         tag (TimeExpired _)             = 15
 267         tag (UnsatisfiedConstraints _)  = 16
 268         tag (UnsupportedOperation _)    = 17
 269         tag (UserError _)               = 18
 270         tag EOF                         = 19
 271 \end{code}
 272
 273 Predicates on IOError; almost no effort made on these so far...
 274
 275 \begin{code}
 276
 277 isAlreadyExistsError (AlreadyExists _) = True
 278 isAlreadyExistsError _                 = False
 279
 280 isAlreadyInUseError (ResourceBusy _) = True
 281 isAlreadyInUseError _                = False
 282
 283 isFullError (ResourceExhausted _) = True
 284 isFullError _                     = False
 285
 286 isEOFError EOF = True
 287 isEOFError _   = True
 288
 289 isIllegalOperation (IllegalOperation _) = True
 290 isIllegalOperation _                    = False
 291
 292 isPermissionError (PermissionDenied _)  = True
 293 isPermissionError _                     = False
 294
 295 isUserError (UserError s) = Just s
 296 isUserError _             = Nothing
 297 \end{code}
 298
 299 Showing @IOError@s
 300
 301 \begin{code}
 302 instance Show IOError where
 303     showsPrec p (AlreadyExists s)       = show2 "AlreadyExists: "       s
 304     showsPrec p (HardwareFault s)       = show2 "HardwareFault: "       s
 305     showsPrec p (IllegalOperation s)    = show2 "IllegalOperation: "    s
 306     showsPrec p (InappropriateType s)   = show2 "InappropriateType: "   s
 307     showsPrec p (Interrupted s)         = show2 "Interrupted: "         s
 308     showsPrec p (InvalidArgument s)     = show2 "InvalidArgument: "     s
 309     showsPrec p (NoSuchThing s)         = show2 "NoSuchThing: "         s
 310     showsPrec p (OtherError s)          = show2 "OtherError: "          s
 311     showsPrec p (PermissionDenied s)    = show2 "PermissionDenied: "    s
 312     showsPrec p (ProtocolError s)       = show2 "ProtocolError: "       s
 313     showsPrec p (ResourceBusy s)        = show2 "ResourceBusy: "        s
 314     showsPrec p (ResourceExhausted s)   = show2 "ResourceExhausted: "   s
 315     showsPrec p (ResourceVanished s)    = show2 "ResourceVanished: "    s
 316     showsPrec p (SystemError s)         = show2 "SystemError: "         s
 317     showsPrec p (TimeExpired s)         = show2 "TimeExpired: "         s
 318     showsPrec p (UnsatisfiedConstraints s) = show2 "UnsatisfiedConstraints: " s
 319     showsPrec p (UnsupportedOperation s)= show2 "UnsupportedOperation: " s
 320     showsPrec p (UserError s)           = showString s
 321     showsPrec p EOF                     = showString "EOF"
 322
 323 show2 x y = showString x . showString y
 324
 325 {-
 326
 327 The @String@ part of an @IOError@ is platform-dependent.  However, to
 328 provide a uniform mechanism for distinguishing among errors within
 329 these broad categories, each platform-specific standard shall specify
 330 the exact strings to be used for particular errors.  For errors not
 331 explicitly mentioned in the standard, any descriptive string may be
 332 used.
 333
 334   SOF 4/96 - added argument to indicate function that flagged error
 335 -}
 336 constructErrorAndFail :: String -> IO a
 337 constructError        :: String -> PrimIO IOError
 338
 339 constructErrorAndFail call_site
 340   = stToIO (constructError call_site) >>= \ io_error ->
 341     fail io_error
 342
 343 constructError call_site
 344   = _casm_ ``%r = ghc_errtype;''    >>= \ (I# errtype#) ->
 345     _casm_ ``%r = ghc_errstr;''     >>= \ str ->
 346     let
 347         msg = call_site ++ ':' : ' ' : unpackCString str
 348     in
 349     return (case errtype# of
 350         ERR_ALREADYEXISTS#              -> AlreadyExists msg
 351         ERR_HARDWAREFAULT#              -> HardwareFault msg
 352         ERR_ILLEGALOPERATION#           -> IllegalOperation msg
 353         ERR_INAPPROPRIATETYPE#          -> InappropriateType msg
 354         ERR_INTERRUPTED#                -> Interrupted msg
 355         ERR_INVALIDARGUMENT#            -> InvalidArgument msg
 356         ERR_NOSUCHTHING#                -> NoSuchThing msg
 357         ERR_OTHERERROR#                 -> OtherError msg
 358         ERR_PERMISSIONDENIED#           -> PermissionDenied msg
 359         ERR_PROTOCOLERROR#              -> ProtocolError msg
 360         ERR_RESOURCEBUSY#               -> ResourceBusy msg
 361         ERR_RESOURCEEXHAUSTED#          -> ResourceExhausted msg
 362         ERR_RESOURCEVANISHED#           -> ResourceVanished msg
 363         ERR_SYSTEMERROR#                -> SystemError msg
 364         ERR_TIMEEXPIRED#                -> TimeExpired msg
 365         ERR_UNSATISFIEDCONSTRAINTS#     -> UnsatisfiedConstraints msg
 366         ERR_UNSUPPORTEDOPERATION#       -> UnsupportedOperation msg
 367         ERR_EOF#                        -> EOF
 368         _                               -> OtherError "bad error construct"
 369     )
 370 \end{code}
 371
 372