% -----------------------------------------------------------------------------
-% $Id: PrelCError.lhs,v 1.2 2001/01/12 17:45:30 qrczak Exp $
+% $Id: PrelCError.lhs,v 1.10 2001/07/13 11:11:34 rrt Exp $
%
% (c) The FFI task force, 2000
%
C-specific Marshalling support: Handling of C "errno" error codes
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsStd.h" #-}
-- this is were we get the CCONST_XXX definitions from that configure
-- calculated for us
-- Haskell representation for "errno" values
--
Errno(..), -- instance: Eq
- e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
+ eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
-- :: Num a
-- => String -> IO a -> IO ()
throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a)
- throwErrnoIfNullRetry -- :: String -> IO (Ptr a) -> IO (Ptr a)
+ throwErrnoIfNullRetry,-- :: String -> IO (Ptr a) -> IO (Ptr a)
+
+ throwErrnoIfRetryMayBlock,
+ throwErrnoIfRetryMayBlock_,
+ throwErrnoIfMinus1RetryMayBlock,
+ throwErrnoIfMinus1RetryMayBlock_,
+ throwErrnoIfNullRetryMayBlock
) where
-- GHC allows us to get at the guts inside IO errors/exceptions
--
#if __GLASGOW_HASKELL__
-#if __GLASGOW_HASKELL__ < 409
-import PrelIOBase (IOError(..), IOErrorType(..))
-#else
import PrelIOBase (Exception(..), IOException(..), IOErrorType(..))
-#endif
#endif /* __GLASGOW_HASKELL__ */
-- regular imports
-- ---------------
-import Monad (liftM)
-
#if __GLASGOW_HASKELL__
import PrelStorable
import PrelMarshalError
import PrelCTypes
+import PrelCString
import PrelIOBase
import PrelPtr
import PrelNum
#else
import Ptr (Ptr, nullPtr)
import CTypes (CInt)
+import CString (peekCString)
import MarshalError (void)
import IO (IOError, Handle, ioError)
#endif
--- system dependent re-definitions
--- -------------------------------
-
--- we bring GHC's `IOErrorType' in scope in other compilers to simplify the
--- routine `errnoToIOError' below
---
-#if !__GLASGOW_HASKELL__
-data IOErrorType
- = AlreadyExists | HardwareFault
- | IllegalOperation | InappropriateType
- | Interrupted | InvalidArgument
- | NoSuchThing | OtherError
- | PermissionDenied | ProtocolError
- | ResourceBusy | ResourceExhausted
- | ResourceVanished | SystemError
- | TimeExpired | UnsatisfiedConstraints
- | UnsupportedOperation
- | EOF
-#endif
-
-
-- "errno" type
-- ------------
+-- import of C function that gives address of errno
+-- This function exists because errno is a variable on some systems, but on
+-- Windows it is a macro for a function...
+foreign import "ghcErrno" unsafe _errno :: Ptr CInt
+
-- Haskell representation for "errno" values
--
newtype Errno = Errno CInt
-- common "errno" symbols
--
-e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
+eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
-- the CCONST_XXX identifiers are cpp symbols whose value is computed by
-- configure
--
-e2BIG = Errno CCONST_E2BIG
-eACCES = Errno CCONST_EACCES
-eADDRINUSE = Errno CCONST_EADDRINUSE
-eADDRNOTAVAIL = Errno CCONST_EADDRNOTAVAIL
-eADV = Errno CCONST_EADV
-eAFNOSUPPORT = Errno CCONST_EAFNOSUPPORT
-eAGAIN = Errno CCONST_EAGAIN
-eALREADY = Errno CCONST_EALREADY
-eBADF = Errno CCONST_EBADF
-eBADMSG = Errno CCONST_EBADMSG
-eBADRPC = Errno CCONST_EBADRPC
-eBUSY = Errno CCONST_EBUSY
-eCHILD = Errno CCONST_ECHILD
-eCOMM = Errno CCONST_ECOMM
-eCONNABORTED = Errno CCONST_ECONNABORTED
-eCONNREFUSED = Errno CCONST_ECONNREFUSED
-eCONNRESET = Errno CCONST_ECONNRESET
-eDEADLK = Errno CCONST_EDEADLK
-eDESTADDRREQ = Errno CCONST_EDESTADDRREQ
-eDIRTY = Errno CCONST_EDIRTY
-eDOM = Errno CCONST_EDOM
-eDQUOT = Errno CCONST_EDQUOT
-eEXIST = Errno CCONST_EEXIST
-eFAULT = Errno CCONST_EFAULT
-eFBIG = Errno CCONST_EFBIG
-eFTYPE = Errno CCONST_EFTYPE
-eHOSTDOWN = Errno CCONST_EHOSTDOWN
-eHOSTUNREACH = Errno CCONST_EHOSTUNREACH
-eIDRM = Errno CCONST_EIDRM
-eILSEQ = Errno CCONST_EILSEQ
-eINPROGRESS = Errno CCONST_EINPROGRESS
-eINTR = Errno CCONST_EINTR
-eINVAL = Errno CCONST_EINVAL
-eIO = Errno CCONST_EIO
-eISCONN = Errno CCONST_EISCONN
-eISDIR = Errno CCONST_EISDIR
-eLOOP = Errno CCONST_ELOOP
-eMFILE = Errno CCONST_EMFILE
-eMLINK = Errno CCONST_EMLINK
-eMSGSIZE = Errno CCONST_EMSGSIZE
-eMULTIHOP = Errno CCONST_EMULTIHOP
-eNAMETOOLONG = Errno CCONST_ENAMETOOLONG
-eNETDOWN = Errno CCONST_ENETDOWN
-eNETRESET = Errno CCONST_ENETRESET
-eNETUNREACH = Errno CCONST_ENETUNREACH
-eNFILE = Errno CCONST_ENFILE
-eNOBUFS = Errno CCONST_ENOBUFS
-eNODATA = Errno CCONST_ENODATA
-eNODEV = Errno CCONST_ENODEV
-eNOENT = Errno CCONST_ENOENT
-eNOEXEC = Errno CCONST_ENOEXEC
-eNOLCK = Errno CCONST_ENOLCK
-eNOLINK = Errno CCONST_ENOLINK
-eNOMEM = Errno CCONST_ENOMEM
-eNOMSG = Errno CCONST_ENOMSG
-eNONET = Errno CCONST_ENONET
-eNOPROTOOPT = Errno CCONST_ENOPROTOOPT
-eNOSPC = Errno CCONST_ENOSPC
-eNOSR = Errno CCONST_ENOSR
-eNOSTR = Errno CCONST_ENOSTR
-eNOSYS = Errno CCONST_ENOSYS
-eNOTBLK = Errno CCONST_ENOTBLK
-eNOTCONN = Errno CCONST_ENOTCONN
-eNOTDIR = Errno CCONST_ENOTDIR
-eNOTEMPTY = Errno CCONST_ENOTEMPTY
-eNOTSOCK = Errno CCONST_ENOTSOCK
-eNOTTY = Errno CCONST_ENOTTY
-eNXIO = Errno CCONST_ENXIO
-eOPNOTSUPP = Errno CCONST_EOPNOTSUPP
-ePERM = Errno CCONST_EPERM
-ePFNOSUPPORT = Errno CCONST_EPFNOSUPPORT
-ePIPE = Errno CCONST_EPIPE
-ePROCLIM = Errno CCONST_EPROCLIM
-ePROCUNAVAIL = Errno CCONST_EPROCUNAVAIL
-ePROGMISMATCH = Errno CCONST_EPROGMISMATCH
-ePROGUNAVAIL = Errno CCONST_EPROGUNAVAIL
-ePROTO = Errno CCONST_EPROTO
-ePROTONOSUPPORT = Errno CCONST_EPROTONOSUPPORT
-ePROTOTYPE = Errno CCONST_EPROTOTYPE
-eRANGE = Errno CCONST_ERANGE
-eREMCHG = Errno CCONST_EREMCHG
-eREMOTE = Errno CCONST_EREMOTE
-eROFS = Errno CCONST_EROFS
-eRPCMISMATCH = Errno CCONST_ERPCMISMATCH
-eRREMOTE = Errno CCONST_ERREMOTE
-eSHUTDOWN = Errno CCONST_ESHUTDOWN
-eSOCKTNOSUPPORT = Errno CCONST_ESOCKTNOSUPPORT
-eSPIPE = Errno CCONST_ESPIPE
-eSRCH = Errno CCONST_ESRCH
-eSRMNT = Errno CCONST_ESRMNT
-eSTALE = Errno CCONST_ESTALE
-eTIME = Errno CCONST_ETIME
-eTIMEDOUT = Errno CCONST_ETIMEDOUT
-eTOOMANYREFS = Errno CCONST_ETOOMANYREFS
-eTXTBSY = Errno CCONST_ETXTBSY
-eUSERS = Errno CCONST_EUSERS
-eWOULDBLOCK = Errno CCONST_EWOULDBLOCK
-eXDEV = Errno CCONST_EXDEV
+eOK = Errno 0
+e2BIG = Errno (CCONST_E2BIG)
+eACCES = Errno (CCONST_EACCES)
+eADDRINUSE = Errno (CCONST_EADDRINUSE)
+eADDRNOTAVAIL = Errno (CCONST_EADDRNOTAVAIL)
+eADV = Errno (CCONST_EADV)
+eAFNOSUPPORT = Errno (CCONST_EAFNOSUPPORT)
+eAGAIN = Errno (CCONST_EAGAIN)
+eALREADY = Errno (CCONST_EALREADY)
+eBADF = Errno (CCONST_EBADF)
+eBADMSG = Errno (CCONST_EBADMSG)
+eBADRPC = Errno (CCONST_EBADRPC)
+eBUSY = Errno (CCONST_EBUSY)
+eCHILD = Errno (CCONST_ECHILD)
+eCOMM = Errno (CCONST_ECOMM)
+eCONNABORTED = Errno (CCONST_ECONNABORTED)
+eCONNREFUSED = Errno (CCONST_ECONNREFUSED)
+eCONNRESET = Errno (CCONST_ECONNRESET)
+eDEADLK = Errno (CCONST_EDEADLK)
+eDESTADDRREQ = Errno (CCONST_EDESTADDRREQ)
+eDIRTY = Errno (CCONST_EDIRTY)
+eDOM = Errno (CCONST_EDOM)
+eDQUOT = Errno (CCONST_EDQUOT)
+eEXIST = Errno (CCONST_EEXIST)
+eFAULT = Errno (CCONST_EFAULT)
+eFBIG = Errno (CCONST_EFBIG)
+eFTYPE = Errno (CCONST_EFTYPE)
+eHOSTDOWN = Errno (CCONST_EHOSTDOWN)
+eHOSTUNREACH = Errno (CCONST_EHOSTUNREACH)
+eIDRM = Errno (CCONST_EIDRM)
+eILSEQ = Errno (CCONST_EILSEQ)
+eINPROGRESS = Errno (CCONST_EINPROGRESS)
+eINTR = Errno (CCONST_EINTR)
+eINVAL = Errno (CCONST_EINVAL)
+eIO = Errno (CCONST_EIO)
+eISCONN = Errno (CCONST_EISCONN)
+eISDIR = Errno (CCONST_EISDIR)
+eLOOP = Errno (CCONST_ELOOP)
+eMFILE = Errno (CCONST_EMFILE)
+eMLINK = Errno (CCONST_EMLINK)
+eMSGSIZE = Errno (CCONST_EMSGSIZE)
+eMULTIHOP = Errno (CCONST_EMULTIHOP)
+eNAMETOOLONG = Errno (CCONST_ENAMETOOLONG)
+eNETDOWN = Errno (CCONST_ENETDOWN)
+eNETRESET = Errno (CCONST_ENETRESET)
+eNETUNREACH = Errno (CCONST_ENETUNREACH)
+eNFILE = Errno (CCONST_ENFILE)
+eNOBUFS = Errno (CCONST_ENOBUFS)
+eNODATA = Errno (CCONST_ENODATA)
+eNODEV = Errno (CCONST_ENODEV)
+eNOENT = Errno (CCONST_ENOENT)
+eNOEXEC = Errno (CCONST_ENOEXEC)
+eNOLCK = Errno (CCONST_ENOLCK)
+eNOLINK = Errno (CCONST_ENOLINK)
+eNOMEM = Errno (CCONST_ENOMEM)
+eNOMSG = Errno (CCONST_ENOMSG)
+eNONET = Errno (CCONST_ENONET)
+eNOPROTOOPT = Errno (CCONST_ENOPROTOOPT)
+eNOSPC = Errno (CCONST_ENOSPC)
+eNOSR = Errno (CCONST_ENOSR)
+eNOSTR = Errno (CCONST_ENOSTR)
+eNOSYS = Errno (CCONST_ENOSYS)
+eNOTBLK = Errno (CCONST_ENOTBLK)
+eNOTCONN = Errno (CCONST_ENOTCONN)
+eNOTDIR = Errno (CCONST_ENOTDIR)
+eNOTEMPTY = Errno (CCONST_ENOTEMPTY)
+eNOTSOCK = Errno (CCONST_ENOTSOCK)
+eNOTTY = Errno (CCONST_ENOTTY)
+eNXIO = Errno (CCONST_ENXIO)
+eOPNOTSUPP = Errno (CCONST_EOPNOTSUPP)
+ePERM = Errno (CCONST_EPERM)
+ePFNOSUPPORT = Errno (CCONST_EPFNOSUPPORT)
+ePIPE = Errno (CCONST_EPIPE)
+ePROCLIM = Errno (CCONST_EPROCLIM)
+ePROCUNAVAIL = Errno (CCONST_EPROCUNAVAIL)
+ePROGMISMATCH = Errno (CCONST_EPROGMISMATCH)
+ePROGUNAVAIL = Errno (CCONST_EPROGUNAVAIL)
+ePROTO = Errno (CCONST_EPROTO)
+ePROTONOSUPPORT = Errno (CCONST_EPROTONOSUPPORT)
+ePROTOTYPE = Errno (CCONST_EPROTOTYPE)
+eRANGE = Errno (CCONST_ERANGE)
+eREMCHG = Errno (CCONST_EREMCHG)
+eREMOTE = Errno (CCONST_EREMOTE)
+eROFS = Errno (CCONST_EROFS)
+eRPCMISMATCH = Errno (CCONST_ERPCMISMATCH)
+eRREMOTE = Errno (CCONST_ERREMOTE)
+eSHUTDOWN = Errno (CCONST_ESHUTDOWN)
+eSOCKTNOSUPPORT = Errno (CCONST_ESOCKTNOSUPPORT)
+eSPIPE = Errno (CCONST_ESPIPE)
+eSRCH = Errno (CCONST_ESRCH)
+eSRMNT = Errno (CCONST_ESRMNT)
+eSTALE = Errno (CCONST_ESTALE)
+eTIME = Errno (CCONST_ETIME)
+eTIMEDOUT = Errno (CCONST_ETIMEDOUT)
+eTOOMANYREFS = Errno (CCONST_ETOOMANYREFS)
+eTXTBSY = Errno (CCONST_ETXTBSY)
+eUSERS = Errno (CCONST_EUSERS)
+eWOULDBLOCK = Errno (CCONST_EWOULDBLOCK)
+eXDEV = Errno (CCONST_EXDEV)
-- checks whether the given errno value is supported on the current
-- architecture
--
isValidErrno :: Errno -> Bool
--
--- the configure script sets all invalid "errno"s to 0
+-- the configure script sets all invalid "errno"s to -1
--
-isValidErrno (Errno errno) = errno /= 0
+isValidErrno (Errno errno) = errno /= -1
-- access to the current thread's "errno" value
-- yield the current thread's "errno" value
--
getErrno :: IO Errno
-getErrno = liftM Errno (peek _errno)
-
+getErrno = do e <- peek _errno; return (Errno e)
-- set the current thread's "errno" value to 0
--
else throwErrno loc
else return res
+-- as `throwErrnoIfRetry', but checks for operations that would block and
+-- executes an alternative action in that case.
+
+throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a
+throwErrnoIfRetryMayBlock pred loc f on_block =
+ do
+ res <- f
+ if pred res
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfRetryMayBlock pred loc f on_block
+ else if err == eWOULDBLOCK || err == eAGAIN
+ then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block
+ else throwErrno loc
+ else return res
+
-- as `throwErrnoIfRetry', but discards the result
--
throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f
+-- as `throwErrnoIfRetryMayBlock', but discards the result
+--
+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
+throwErrnoIfRetryMayBlock_ pred loc f on_block
+ = void $ throwErrnoIfRetryMayBlock pred loc f on_block
+
-- throws "errno" if a result of "-1" is returned
--
throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1)
+-- as throwErrnoIfMinus1Retry, but checks for operations that would block
+--
+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a
+throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1)
+
+-- as `throwErrnoIfMinus1RetryMayBlock', but discards the result
+--
+throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()
+throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1)
+
-- throws "errno" if a result of a NULL pointer is returned
--
throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr)
+-- as throwErrnoIfNullRetry, but checks for operations that would block
+--
+throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)
+throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr)
-- conversion of an "errno" value into IO error
-- --------------------------------------------
-- and an optional filename into a matching IO error
--
errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError
-errnoToIOError loc errno@(Errno no) maybeHdl maybeName =
+errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do
+ str <- strerror errno >>= peekCString
#if __GLASGOW_HASKELL__
- IOException (IOError maybeHdl errType loc str maybeName)
+ return (IOException (IOError maybeHdl errType loc str maybeName))
+ where
+ errType
+ | errno == eOK = OtherError
+ | errno == e2BIG = ResourceExhausted
+ | errno == eACCES = PermissionDenied
+ | errno == eADDRINUSE = ResourceBusy
+ | errno == eADDRNOTAVAIL = UnsupportedOperation
+ | errno == eADV = OtherError
+ | errno == eAFNOSUPPORT = UnsupportedOperation
+ | errno == eAGAIN = ResourceExhausted
+ | errno == eALREADY = AlreadyExists
+ | errno == eBADF = OtherError
+ | errno == eBADMSG = InappropriateType
+ | errno == eBADRPC = OtherError
+ | errno == eBUSY = ResourceBusy
+ | errno == eCHILD = NoSuchThing
+ | errno == eCOMM = ResourceVanished
+ | errno == eCONNABORTED = OtherError
+ | errno == eCONNREFUSED = NoSuchThing
+ | errno == eCONNRESET = ResourceVanished
+ | errno == eDEADLK = ResourceBusy
+ | errno == eDESTADDRREQ = InvalidArgument
+ | errno == eDIRTY = UnsatisfiedConstraints
+ | errno == eDOM = InvalidArgument
+ | errno == eDQUOT = PermissionDenied
+ | errno == eEXIST = AlreadyExists
+ | errno == eFAULT = OtherError
+ | errno == eFBIG = PermissionDenied
+ | errno == eFTYPE = InappropriateType
+ | errno == eHOSTDOWN = NoSuchThing
+ | errno == eHOSTUNREACH = NoSuchThing
+ | errno == eIDRM = ResourceVanished
+ | errno == eILSEQ = InvalidArgument
+ | errno == eINPROGRESS = AlreadyExists
+ | errno == eINTR = Interrupted
+ | errno == eINVAL = InvalidArgument
+ | errno == eIO = HardwareFault
+ | errno == eISCONN = AlreadyExists
+ | errno == eISDIR = InappropriateType
+ | errno == eLOOP = InvalidArgument
+ | errno == eMFILE = ResourceExhausted
+ | errno == eMLINK = ResourceExhausted
+ | errno == eMSGSIZE = ResourceExhausted
+ | errno == eMULTIHOP = UnsupportedOperation
+ | errno == eNAMETOOLONG = InvalidArgument
+ | errno == eNETDOWN = ResourceVanished
+ | errno == eNETRESET = ResourceVanished
+ | errno == eNETUNREACH = NoSuchThing
+ | errno == eNFILE = ResourceExhausted
+ | errno == eNOBUFS = ResourceExhausted
+ | errno == eNODATA = NoSuchThing
+ | errno == eNODEV = NoSuchThing
+ | errno == eNOENT = NoSuchThing
+ | errno == eNOEXEC = InvalidArgument
+ | errno == eNOLCK = ResourceExhausted
+ | errno == eNOLINK = ResourceVanished
+ | errno == eNOMEM = ResourceExhausted
+ | errno == eNOMSG = NoSuchThing
+ | errno == eNONET = NoSuchThing
+ | errno == eNOPROTOOPT = UnsupportedOperation
+ | errno == eNOSPC = ResourceExhausted
+ | errno == eNOSR = ResourceExhausted
+ | errno == eNOSTR = InvalidArgument
+ | errno == eNOSYS = UnsupportedOperation
+ | errno == eNOTBLK = InvalidArgument
+ | errno == eNOTCONN = InvalidArgument
+ | errno == eNOTDIR = InappropriateType
+ | errno == eNOTEMPTY = UnsatisfiedConstraints
+ | errno == eNOTSOCK = InvalidArgument
+ | errno == eNOTTY = IllegalOperation
+ | errno == eNXIO = NoSuchThing
+ | errno == eOPNOTSUPP = UnsupportedOperation
+ | errno == ePERM = PermissionDenied
+ | errno == ePFNOSUPPORT = UnsupportedOperation
+ | errno == ePIPE = ResourceVanished
+ | errno == ePROCLIM = PermissionDenied
+ | errno == ePROCUNAVAIL = UnsupportedOperation
+ | errno == ePROGMISMATCH = ProtocolError
+ | errno == ePROGUNAVAIL = UnsupportedOperation
+ | errno == ePROTO = ProtocolError
+ | errno == ePROTONOSUPPORT = ProtocolError
+ | errno == ePROTOTYPE = ProtocolError
+ | errno == eRANGE = UnsupportedOperation
+ | errno == eREMCHG = ResourceVanished
+ | errno == eREMOTE = IllegalOperation
+ | errno == eROFS = PermissionDenied
+ | errno == eRPCMISMATCH = ProtocolError
+ | errno == eRREMOTE = IllegalOperation
+ | errno == eSHUTDOWN = IllegalOperation
+ | errno == eSOCKTNOSUPPORT = UnsupportedOperation
+ | errno == eSPIPE = UnsupportedOperation
+ | errno == eSRCH = NoSuchThing
+ | errno == eSRMNT = UnsatisfiedConstraints
+ | errno == eSTALE = ResourceVanished
+ | errno == eTIME = TimeExpired
+ | errno == eTIMEDOUT = TimeExpired
+ | errno == eTOOMANYREFS = ResourceExhausted
+ | errno == eTXTBSY = ResourceBusy
+ | errno == eUSERS = ResourceExhausted
+ | errno == eWOULDBLOCK = OtherError
+ | errno == eXDEV = UnsupportedOperation
+ | otherwise = OtherError
#else
- userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName)
+ return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))
#endif
- where
- (errType, str)
- | no == 0 = (OtherError,
- "no error")
- | errno == e2BIG = (ResourceExhausted,
- "argument list too long")
- | errno == eACCES = (PermissionDenied,
- "inadequate access permission")
- | errno == eADDRINUSE = (ResourceBusy,
- "address already in use")
- | errno == eADDRNOTAVAIL = (UnsupportedOperation,
- "address not available")
- | errno == eADV = (OtherError,
- "RFS advertise error")
- | errno == eAFNOSUPPORT = (UnsupportedOperation,
- "address family not supported by " ++
- "protocol family")
- -- no multiline strings with cpp
- | errno == eAGAIN = (ResourceExhausted,
- "insufficient resources")
- | errno == eALREADY = (AlreadyExists,
- "operation already in progress")
- | errno == eBADF = (OtherError,
- "internal error (EBADF)")
- | errno == eBADMSG = (InappropriateType,
- "next message has wrong type")
- | errno == eBADRPC = (OtherError,
- "invalid RPC request or response")
- | errno == eBUSY = (ResourceBusy,
- "device busy")
- | errno == eCHILD = (NoSuchThing,
- "no child processes")
- | errno == eCOMM = (ResourceVanished,
- "no virtual circuit could be found")
- | errno == eCONNABORTED = (OtherError,
- "aborted connection")
- | errno == eCONNREFUSED = (NoSuchThing,
- "no listener on remote host")
- | errno == eCONNRESET = (ResourceVanished,
- "connection reset by peer")
- | errno == eDEADLK = (ResourceBusy,
- "resource deadlock avoided")
- | errno == eDESTADDRREQ = (InvalidArgument,
- "destination address required")
- | errno == eDIRTY = (UnsatisfiedConstraints,
- "file system dirty")
- | errno == eDOM = (InvalidArgument,
- "argument too large")
- | errno == eDQUOT = (PermissionDenied,
- "quota exceeded")
- | errno == eEXIST = (AlreadyExists,
- "file already exists")
- | errno == eFAULT = (OtherError,
- "internal error (EFAULT)")
- | errno == eFBIG = (PermissionDenied,
- "file too large")
- | errno == eFTYPE = (InappropriateType,
- "inappropriate NFS file type or format")
- | errno == eHOSTDOWN = (NoSuchThing,
- "destination host down")
- | errno == eHOSTUNREACH = (NoSuchThing,
- "remote host is unreachable")
- | errno == eIDRM = (ResourceVanished,
- "IPC identifier removed")
- | errno == eILSEQ = (InvalidArgument,
- "invalid wide character")
- | errno == eINPROGRESS = (AlreadyExists,
- "operation now in progress")
- | errno == eINTR = (Interrupted,
- "interrupted system call")
- | errno == eINVAL = (InvalidArgument,
- "invalid argument")
- | errno == eIO = (HardwareFault,
- "unknown I/O fault")
- | errno == eISCONN = (AlreadyExists,
- "socket is already connected")
- | errno == eISDIR = (InappropriateType,
- "file is a directory")
- | errno == eLOOP = (InvalidArgument,
- "too many symbolic links")
- | errno == eMFILE = (ResourceExhausted,
- "process file table full")
- | errno == eMLINK = (ResourceExhausted,
- "too many links")
- | errno == eMSGSIZE = (ResourceExhausted,
- "message too long")
- | errno == eMULTIHOP = (UnsupportedOperation,
- "multi-hop RFS request")
- | errno == eNAMETOOLONG = (InvalidArgument,
- "filename too long")
- | errno == eNETDOWN = (ResourceVanished,
- "network is down")
- | errno == eNETRESET = (ResourceVanished,
- "remote host rebooted; connection lost")
- | errno == eNETUNREACH = (NoSuchThing,
- "remote network is unreachable")
- | errno == eNFILE = (ResourceExhausted,
- "system file table full")
- | errno == eNOBUFS = (ResourceExhausted,
- "no buffer space available")
- | errno == eNODATA = (NoSuchThing,
- "no message on the stream head read " ++
- "queue")
- -- no multiline strings with cpp
- | errno == eNODEV = (NoSuchThing,
- "no such device")
- | errno == eNOENT = (NoSuchThing,
- "no such file or directory")
- | errno == eNOEXEC = (InvalidArgument,
- "not an executable file")
- | errno == eNOLCK = (ResourceExhausted,
- "no file locks available")
- | errno == eNOLINK = (ResourceVanished,
- "RFS link has been severed")
- | errno == eNOMEM = (ResourceExhausted,
- "not enough virtual memory")
- | errno == eNOMSG = (NoSuchThing,
- "no message of desired type")
- | errno == eNONET = (NoSuchThing,
- "host is not on a network")
- | errno == eNOPROTOOPT = (UnsupportedOperation,
- "operation not supported by protocol")
- | errno == eNOSPC = (ResourceExhausted,
- "no space left on device")
- | errno == eNOSR = (ResourceExhausted,
- "out of stream resources")
- | errno == eNOSTR = (InvalidArgument,
- "not a stream device")
- | errno == eNOSYS = (UnsupportedOperation,
- "function not implemented")
- | errno == eNOTBLK = (InvalidArgument,
- "not a block device")
- | errno == eNOTCONN = (InvalidArgument,
- "socket is not connected")
- | errno == eNOTDIR = (InappropriateType,
- "not a directory")
- | errno == eNOTEMPTY = (UnsatisfiedConstraints,
- "directory not empty")
- | errno == eNOTSOCK = (InvalidArgument,
- "not a socket")
- | errno == eNOTTY = (IllegalOperation,
- "inappropriate ioctl for device")
- | errno == eNXIO = (NoSuchThing,
- "no such device or address")
- | errno == eOPNOTSUPP = (UnsupportedOperation,
- "operation not supported on socket")
- | errno == ePERM = (PermissionDenied,
- "privileged operation")
- | errno == ePFNOSUPPORT = (UnsupportedOperation,
- "protocol family not supported")
- | errno == ePIPE = (ResourceVanished,
- "broken pipe")
- | errno == ePROCLIM = (PermissionDenied,
- "too many processes")
- | errno == ePROCUNAVAIL = (UnsupportedOperation,
- "unimplemented RPC procedure")
- | errno == ePROGMISMATCH = (ProtocolError,
- "unsupported RPC program version")
- | errno == ePROGUNAVAIL = (UnsupportedOperation,
- "RPC program unavailable")
- | errno == ePROTO = (ProtocolError,
- "error in streams protocol")
- | errno == ePROTONOSUPPORT = (ProtocolError,
- "protocol not supported")
- | errno == ePROTOTYPE = (ProtocolError,
- "wrong protocol for socket")
- | errno == eRANGE = (UnsupportedOperation,
- "result too large")
- | errno == eREMCHG = (ResourceVanished,
- "remote address changed")
- | errno == eREMOTE = (IllegalOperation,
- "too many levels of remote in path")
- | errno == eROFS = (PermissionDenied,
- "read-only file system")
- | errno == eRPCMISMATCH = (ProtocolError,
- "RPC version is wrong")
- | errno == eRREMOTE = (IllegalOperation,
- "object is remote")
- | errno == eSHUTDOWN = (IllegalOperation,
- "can't send after socket shutdown")
- | errno == eSOCKTNOSUPPORT = (UnsupportedOperation,
- "socket type not supported")
- | errno == eSPIPE = (UnsupportedOperation,
- "can't seek on a pipe")
- | errno == eSRCH = (NoSuchThing,
- "no such process")
- | errno == eSRMNT = (UnsatisfiedConstraints,
- "RFS resources still mounted by " ++
- "remote host(s)")
- -- no multiline strings with cpp
- | errno == eSTALE = (ResourceVanished,
- "stale NFS file handle")
- | errno == eTIME = (TimeExpired,
- "timer expired")
- | errno == eTIMEDOUT = (TimeExpired,
- "connection timed out")
- | errno == eTOOMANYREFS = (ResourceExhausted,
- "too many references; can't splice")
- | errno == eTXTBSY = (ResourceBusy,
- "text file in-use")
- | errno == eUSERS = (ResourceExhausted,
- "quota table full")
- | errno == eWOULDBLOCK = (OtherError,
- "operation would block")
- | errno == eXDEV = (UnsupportedOperation,
- "can't make a cross-device link")
- | otherwise = (OtherError,
- "unexpected error (error code: "
- ++ show no ++")")
-
-foreign label "errno" _errno :: Ptr CInt
- -- FIXME: this routine should eventually be provided by the Haskell runtime
- -- and guarantee that the "errno" of the last operation performed by
- -- the current thread is returned
+
+foreign import unsafe strerror :: Errno -> IO (Ptr CChar)
\end{code}