{-# LINE 1 "Data/Text/ICU/Error/Internal.hsc" #-}
{-# LANGUAGE BangPatterns, DeriveDataTypeable, ForeignFunctionInterface,
    RecordWildCards, ScopedTypeVariables #-}

module Data.Text.ICU.Error.Internal
    (
    -- * Types
      ICUError(..)
    -- ** Low-level types
    , UErrorCode
    , ParseError(errError, errLine, errOffset)
    , UParseError
    -- * Functions
    , isFailure
    , isSuccess
    , errorName
    , handleError
    , handleOverflowError
    , handleParseError
    , throwOnError
    , withError
    ) where

import Control.DeepSeq (NFData(..))
import Control.Exception (Exception, throwIO)
import Data.Function (fix)
import Foreign.Ptr (Ptr)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
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

-- | ICU error type.  This is an instance of the 'Exception' type
-- class.  A value of this type may be thrown as an exception by most
-- ICU functions.
newtype ICUError = ICUError {
      ICUError -> UErrorCode
fromErrorCode :: UErrorCode
    } deriving (ICUError -> ICUError -> Bool
(ICUError -> ICUError -> Bool)
-> (ICUError -> ICUError -> Bool) -> Eq ICUError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ICUError -> ICUError -> Bool
$c/= :: ICUError -> ICUError -> Bool
== :: ICUError -> ICUError -> Bool
$c== :: ICUError -> ICUError -> Bool
Eq, Typeable)

instance Show ICUError where
    show :: ICUError -> String
show ICUError
code = String
"ICUError " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ICUError -> String
errorName ICUError
code

instance Exception ICUError

instance NFData ICUError where
    rnf :: ICUError -> ()
rnf !ICUError
_ = ()

-- | Detailed information about parsing errors.  Used by ICU parsing
-- engines that parse long rules, patterns, or programs, where the
-- text being parsed is long enough that more information than an
-- 'ICUError' is needed to localize the error.
data ParseError = ParseError {
      ParseError -> ICUError
errError :: ICUError
    , ParseError -> Maybe Int
errLine :: !(Maybe Int)
    -- ^ The line on which the error occured.  If the parser uses this
    -- field, it sets it to the line number of the source text line on
    -- which the error appears, which will be be a positive value.  If
    -- the parser does not support line numbers, the value will be
    -- 'Nothing'.
    , ParseError -> Maybe Int
errOffset :: !(Maybe Int)
    -- ^ The character offset to the error.  If the 'errLine' field is
    -- 'Just' some value, then this field contains the offset from the
    -- beginning of the line that contains the error.  Otherwise, it
    -- represents the offset from the start of the text.  If the
    -- parser does not support this field, it will have a value of
    -- 'Nothing'.
    } deriving (Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show, Typeable)

instance NFData ParseError where
    rnf :: ParseError -> ()
rnf ParseError{Maybe Int
ICUError
errOffset :: Maybe Int
errLine :: Maybe Int
errError :: ICUError
errOffset :: ParseError -> Maybe Int
errLine :: ParseError -> Maybe Int
errError :: ParseError -> ICUError
..} = ICUError -> ()
forall a. NFData a => a -> ()
rnf ICUError
errError () -> () -> ()
`seq` Maybe Int -> ()
forall a. NFData a => a -> ()
rnf Maybe Int
errLine () -> () -> ()
`seq` Maybe Int -> ()
forall a. NFData a => a -> ()
rnf Maybe Int
errOffset

type UParseError = ParseError

instance Exception ParseError

-- | Indicate whether the given error code is a success.
isSuccess :: ICUError -> Bool
{-# INLINE isSuccess #-}
isSuccess :: ICUError -> Bool
isSuccess = (UErrorCode -> UErrorCode -> Bool
forall a. Ord a => a -> a -> Bool
<= UErrorCode
0) (UErrorCode -> Bool)
-> (ICUError -> UErrorCode) -> ICUError -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ICUError -> UErrorCode
fromErrorCode

-- | Indicate whether the given error code is a failure.
isFailure :: ICUError -> Bool
{-# INLINE isFailure #-}
isFailure :: ICUError -> Bool
isFailure = (UErrorCode -> UErrorCode -> Bool
forall a. Ord a => a -> a -> Bool
> UErrorCode
0) (UErrorCode -> Bool)
-> (ICUError -> UErrorCode) -> ICUError -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ICUError -> UErrorCode
fromErrorCode

-- | Throw an exception if the given code is actually an error.
throwOnError :: UErrorCode -> IO ()
{-# INLINE throwOnError #-}
throwOnError :: UErrorCode -> IO ()
throwOnError UErrorCode
code = do
  let err :: ICUError
err = (UErrorCode -> ICUError
ICUError UErrorCode
code)
  if ICUError -> Bool
isFailure ICUError
err
    then ICUError -> IO ()
forall e a. Exception e => e -> IO a
throwIO ICUError
err
    else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

withError :: (Ptr UErrorCode -> IO a) -> IO (ICUError, a)
{-# INLINE withError #-}
withError :: forall a. (Ptr UErrorCode -> IO a) -> IO (ICUError, a)
withError Ptr UErrorCode -> IO a
action = UErrorCode
-> (Ptr UErrorCode -> IO (ICUError, a)) -> IO (ICUError, a)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with UErrorCode
0 ((Ptr UErrorCode -> IO (ICUError, a)) -> IO (ICUError, a))
-> (Ptr UErrorCode -> IO (ICUError, a)) -> IO (ICUError, a)
forall a b. (a -> b) -> a -> b
$ \Ptr UErrorCode
errPtr -> do
                     a
ret <- Ptr UErrorCode -> IO a
action Ptr UErrorCode
errPtr
                     UErrorCode
err <- Ptr UErrorCode -> IO UErrorCode
forall a. Storable a => Ptr a -> IO a
peek Ptr UErrorCode
errPtr
                     (ICUError, a) -> IO (ICUError, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (UErrorCode -> ICUError
ICUError UErrorCode
err, a
ret)

handleError :: (Ptr UErrorCode -> IO a) -> IO a
{-# INLINE handleError #-}
handleError :: forall a. (Ptr UErrorCode -> IO a) -> IO a
handleError Ptr UErrorCode -> IO a
action = UErrorCode -> (Ptr UErrorCode -> IO a) -> IO a
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with UErrorCode
0 ((Ptr UErrorCode -> IO a) -> IO a)
-> (Ptr UErrorCode -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr UErrorCode
errPtr -> do
                       a
ret <- Ptr UErrorCode -> IO a
action Ptr UErrorCode
errPtr
                       UErrorCode -> IO ()
throwOnError (UErrorCode -> IO ()) -> IO UErrorCode -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr UErrorCode -> IO UErrorCode
forall a. Storable a => Ptr a -> IO a
peek Ptr UErrorCode
errPtr
                       a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret

-- | Deal with ICU functions that report a buffer overflow error if we
-- give them an insufficiently large buffer.  Our first call will
-- report a buffer overflow, in which case we allocate a correctly
-- sized buffer and try again.
handleOverflowError :: (Storable a) =>
                       Int
                    -- ^ Initial guess at buffer size.
                    -> (Ptr a -> Int32 -> Ptr UErrorCode -> IO Int32)
                    -- ^ Function that retrieves data.
                    -> (Ptr a -> Int -> IO b)
                    -- ^ Function that fills destination buffer if no
                    -- overflow occurred.
                    -> IO b
handleOverflowError :: forall a b.
Storable a =>
Int
-> (Ptr a -> Int32 -> Ptr UErrorCode -> IO Int32)
-> (Ptr a -> Int -> IO b)
-> IO b
handleOverflowError Int
guess Ptr a -> Int32 -> Ptr UErrorCode -> IO Int32
fill Ptr a -> Int -> IO b
retrieve =
  (Ptr UErrorCode -> IO b) -> IO b
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr UErrorCode -> IO b) -> IO b)
-> (Ptr UErrorCode -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr UErrorCode
uerrPtr -> (((Int -> IO b) -> Int -> IO b) -> Int -> IO b)
-> Int -> ((Int -> IO b) -> Int -> IO b) -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int -> IO b) -> Int -> IO b) -> Int -> IO b
forall a. (a -> a) -> a
fix Int
guess (((Int -> IO b) -> Int -> IO b) -> IO b)
-> ((Int -> IO b) -> Int -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Int -> IO b
loop Int
n ->
    ((Int32 -> IO b) -> (b -> IO b) -> Either Int32 b -> IO b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Int -> IO b
loop (Int -> IO b) -> (Int32 -> Int) -> Int32 -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Int32 b -> IO b) -> IO (Either Int32 b) -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO (Either Int32 b) -> IO b)
-> ((Ptr a -> IO (Either Int32 b)) -> IO (Either Int32 b))
-> (Ptr a -> IO (Either Int32 b))
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Ptr a -> IO (Either Int32 b)) -> IO (Either Int32 b)
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n ((Ptr a -> IO (Either Int32 b)) -> IO b)
-> (Ptr a -> IO (Either Int32 b)) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
      Ptr UErrorCode -> UErrorCode -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr UErrorCode
uerrPtr UErrorCode
0
      Int32
ret <- Ptr a -> Int32 -> Ptr UErrorCode -> IO Int32
fill Ptr a
ptr (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Ptr UErrorCode
uerrPtr
      UErrorCode
err <- Ptr UErrorCode -> IO UErrorCode
forall a. Storable a => Ptr a -> IO a
peek Ptr UErrorCode
uerrPtr
      case Any
forall a. HasCallStack => a
undefined of
        Any
_| UErrorCode
err UErrorCode -> UErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== (UErrorCode
15)
{-# LINE 139 "Data/Text/ICU/Error/Internal.hsc" #-}
                     -> Either Int32 b -> IO (Either Int32 b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32 -> Either Int32 b
forall a b. a -> Either a b
Left Int32
ret)
         | UErrorCode
err UErrorCode -> UErrorCode -> Bool
forall a. Ord a => a -> a -> Bool
> UErrorCode
0   -> ICUError -> IO (Either Int32 b)
forall e a. Exception e => e -> IO a
throwIO (UErrorCode -> ICUError
ICUError UErrorCode
err)
         | Bool
otherwise -> b -> Either Int32 b
forall a b. b -> Either a b
Right (b -> Either Int32 b) -> IO b -> IO (Either Int32 b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr a -> Int -> IO b
retrieve Ptr a
ptr (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ret)

handleParseError :: (ICUError -> Bool)
                 -> (Ptr UParseError -> Ptr UErrorCode -> IO a) -> IO a
handleParseError :: forall a.
(ICUError -> Bool)
-> (Ptr ParseError -> Ptr UErrorCode -> IO a) -> IO a
handleParseError ICUError -> Bool
isParseError Ptr ParseError -> Ptr UErrorCode -> IO a
action = UErrorCode -> (Ptr UErrorCode -> IO a) -> IO a
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with UErrorCode
0 ((Ptr UErrorCode -> IO a) -> IO a)
-> (Ptr UErrorCode -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr UErrorCode
uerrPtr ->
  Int -> (Ptr ParseError -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ((Int
72)) ((Ptr ParseError -> IO a) -> IO a)
-> (Ptr ParseError -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr ParseError
perrPtr -> do
{-# LINE 147 "Data/Text/ICU/Error/Internal.hsc" #-}
    ret <- action perrPtr uerrPtr
    err <- ICUError `fmap` peek uerrPtr
    case undefined of
     _| isParseError err -> throwParseError perrPtr err
      | isFailure err -> throwIO err
      | otherwise     -> return ret

throwParseError :: Ptr UParseError -> ICUError -> IO a
throwParseError :: forall a. Ptr ParseError -> ICUError -> IO a
throwParseError Ptr ParseError
ptr ICUError
err = do
  (Int32
line::Int32) <- (\Ptr ParseError
hsc_ptr -> Ptr ParseError -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr ParseError
hsc_ptr Int
0) Ptr ParseError
ptr
{-# LINE 157 "Data/Text/ICU/Error/Internal.hsc" #-}
  (offset::Int32) <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
{-# LINE 158 "Data/Text/ICU/Error/Internal.hsc" #-}
  let wrap k = if k == -1 then Nothing else Just $! fromIntegral k
  ParseError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ParseError -> IO a) -> ParseError -> IO a
forall a b. (a -> b) -> a -> b
$! ICUError -> Maybe Int -> Maybe Int -> ParseError
ParseError ICUError
err (Int32 -> Maybe Int
forall {a} {a}. (Integral a, Num a) => a -> Maybe a
wrap Int32
line) (Int32 -> Maybe Int
forall {a} {a}. (Integral a, Num a) => a -> Maybe a
wrap Int32
offset)

-- | Return a string representing the name of the given error code.
errorName :: ICUError -> String
errorName :: ICUError -> String
errorName ICUError
code = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$
                 CString -> IO String
peekCString (UErrorCode -> CString
u_errorName (ICUError -> UErrorCode
fromErrorCode ICUError
code))

foreign import ccall unsafe "hs_text_icu.h __hs_u_errorName" u_errorName
    :: UErrorCode -> CString