module Data.Text.ICU.Error.Internal
(
ICUError(..)
, UErrorCode
, ParseError(errError, errLine, errOffset)
, UParseError
, isFailure
, isSuccess
, errorName
, handleError
, handleOverflowError
, handleParseError
, throwOnError
, withError
) where
import Control.Exception (Exception, throwIO)
import Data.Function (fix)
import Foreign.Ptr (Ptr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (with)
import Foreign.Marshal.Array (allocaArray)
import Data.Int (Int32)
import Data.Typeable (Typeable)
import Foreign.C.String (CString, peekCString)
import Foreign.C.Types (CInt(..))
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)
type UErrorCode = CInt
newtype ICUError = ICUError {
fromErrorCode :: UErrorCode
} deriving (Eq, Typeable)
instance Show ICUError where
show code = "ICUError " ++ errorName code
instance Exception ICUError
data ParseError = ParseError {
errError :: ICUError
, errLine :: !(Maybe Int)
, errOffset :: !(Maybe Int)
} deriving (Show, Typeable)
type UParseError = ParseError
instance Exception ParseError
instance Storable ParseError where
sizeOf _ = (72)
alignment _ = alignment (undefined :: CString)
peek ptr = do
(line::Int32) <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
(offset::Int32) <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
let wrap k = if k == 1 then Nothing else Just $! fromIntegral k
return $! ParseError undefined (wrap line) (wrap offset)
isSuccess :: ICUError -> Bool
isSuccess = (<= 0) . fromErrorCode
isFailure :: ICUError -> Bool
isFailure = (> 0) . fromErrorCode
throwOnError :: UErrorCode -> IO ()
throwOnError code = do
let err = (ICUError code)
if isFailure err
then throwIO err
else return ()
withError :: (Ptr UErrorCode -> IO a) -> IO (ICUError, a)
withError action = with 0 $ \errPtr -> do
ret <- action errPtr
err <- peek errPtr
return (ICUError err, ret)
handleError :: (Ptr UErrorCode -> IO a) -> IO a
handleError action = with 0 $ \errPtr -> do
ret <- action errPtr
throwOnError =<< peek errPtr
return ret
handleOverflowError :: (Storable a) =>
Int
-> (Ptr a -> Int32 -> Ptr UErrorCode -> IO Int32)
-> (Ptr a -> Int -> IO b)
-> IO b
handleOverflowError guess fill retrieve =
alloca $ \uerrPtr -> flip fix guess $ \loop n ->
(either (loop . fromIntegral) return =<<) . allocaArray n $ \ptr -> do
poke uerrPtr 0
ret <- fill ptr (fromIntegral n) uerrPtr
err <- peek uerrPtr
case undefined of
_| err == (15)
-> return (Left ret)
| err > 0 -> throwIO (ICUError err)
| otherwise -> Right `fmap` retrieve ptr (fromIntegral ret)
handleParseError :: (ICUError -> Bool)
-> (Ptr UParseError -> Ptr UErrorCode -> IO a) -> IO a
handleParseError isParseError action = with 0 $ \uerrPtr ->
alloca $ \perrPtr -> do
ret <- action perrPtr uerrPtr
err <- ICUError `fmap` peek uerrPtr
case undefined of
_| isParseError err -> do
perr <- peek perrPtr
throwIO perr { errError = err }
| isFailure err -> throwIO err
| otherwise -> return ret
errorName :: ICUError -> String
errorName code = unsafePerformIO $
peekCString (u_errorName (fromErrorCode code))
foreign import ccall unsafe "hs_text_icu.h __hs_u_errorName" u_errorName
:: UErrorCode -> CString