{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Hermes.Decoder.Types
( Decoder(runDecoder)
, HermesEnv(..)
, HermesException(..)
, DocumentError(path, errorMsg, docLocation, docDebug)
, allocaValue
, allocaArray
, allocaArrayIter
, allocaObject
, allocaObjectIter
, handleErrorCode
, typePrefix
, withDocumentPointer
, withParserPointer
, withHermesEnv
) where
import Control.Applicative (Alternative(..))
import Control.DeepSeq (NFData)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Reader (ReaderT)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import UnliftIO.Exception (Exception, bracket, catch, throwIO)
import UnliftIO.Foreign
( CInt
, ForeignPtr
, allocaBytes
, finalizeForeignPtr
, peekCString
, withForeignPtr
)
import Data.Hermes.SIMDJSON.Bindings (getErrorMessageImpl)
import Data.Hermes.SIMDJSON.Types
( Array(..)
, ArrayIter(..)
, Document(..)
, Object(..)
, ObjectIter(..)
, Parser(..)
, SIMDDocument
, SIMDErrorCode(..)
, SIMDParser
, Value(..)
)
import Data.Hermes.SIMDJSON.Wrapper
newtype Decoder a = Decoder { forall a. Decoder a -> ReaderT HermesEnv IO a
runDecoder :: ReaderT HermesEnv IO a }
deriving newtype
( forall a b. a -> Decoder b -> Decoder a
forall a b. (a -> b) -> Decoder a -> Decoder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Decoder b -> Decoder a
$c<$ :: forall a b. a -> Decoder b -> Decoder a
fmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
$cfmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
Functor
, Functor Decoder
forall a. a -> Decoder a
forall a b. Decoder a -> Decoder b -> Decoder a
forall a b. Decoder a -> Decoder b -> Decoder b
forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Decoder a -> Decoder b -> Decoder a
$c<* :: forall a b. Decoder a -> Decoder b -> Decoder a
*> :: forall a b. Decoder a -> Decoder b -> Decoder b
$c*> :: forall a b. Decoder a -> Decoder b -> Decoder b
liftA2 :: forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
$cliftA2 :: forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
<*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
$c<*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
pure :: forall a. a -> Decoder a
$cpure :: forall a. a -> Decoder a
Applicative
, Applicative Decoder
forall a. a -> Decoder a
forall a b. Decoder a -> Decoder b -> Decoder b
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Decoder a
$creturn :: forall a. a -> Decoder a
>> :: forall a b. Decoder a -> Decoder b -> Decoder b
$c>> :: forall a b. Decoder a -> Decoder b -> Decoder b
>>= :: forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
$c>>= :: forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
Monad
, Monad Decoder
forall a. IO a -> Decoder a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Decoder a
$cliftIO :: forall a. IO a -> Decoder a
MonadIO
, MonadReader HermesEnv
, MonadIO Decoder
forall b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
$cwithRunInIO :: forall b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
MonadUnliftIO
)
instance Alternative Decoder where
empty :: forall a. Decoder a
empty = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unspecified error"
Decoder a
ad <|> :: forall a. Decoder a -> Decoder a -> Decoder a
<|> Decoder a
bd = Decoder a
ad forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(HermesException
_err :: HermesException) -> Decoder a
bd)
instance MonadFail Decoder where
{-# INLINE fail #-}
fail :: forall a. String -> Decoder a
fail = forall a. Text -> Decoder a
throwHermes forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
data HermesEnv =
HermesEnv
{ HermesEnv -> ForeignPtr SIMDParser
hParser :: !(ForeignPtr SIMDParser)
, HermesEnv -> ForeignPtr SIMDDocument
hDocument :: !(ForeignPtr SIMDDocument)
, HermesEnv -> Text
hPath :: !Text
}
mkHermesEnv :: Maybe Int -> IO HermesEnv
mkHermesEnv :: Maybe Int -> IO HermesEnv
mkHermesEnv Maybe Int
mCapacity = do
ForeignPtr SIMDParser
parser <- Maybe Int -> IO (ForeignPtr SIMDParser)
mkSIMDParser Maybe Int
mCapacity
ForeignPtr SIMDDocument
document <- IO (ForeignPtr SIMDDocument)
mkSIMDDocument
forall (f :: * -> *) a. Applicative f => a -> f a
pure HermesEnv
{ hParser :: ForeignPtr SIMDParser
hParser = ForeignPtr SIMDParser
parser
, hDocument :: ForeignPtr SIMDDocument
hDocument = ForeignPtr SIMDDocument
document
, hPath :: Text
hPath = Text
""
}
mkHermesEnv_ :: IO HermesEnv
mkHermesEnv_ :: IO HermesEnv
mkHermesEnv_ = Maybe Int -> IO HermesEnv
mkHermesEnv forall a. Maybe a
Nothing
cleanupHermesEnv :: HermesEnv -> IO ()
cleanupHermesEnv :: HermesEnv -> IO ()
cleanupHermesEnv HermesEnv
hEnv = do
forall (m :: * -> *) a. MonadIO m => ForeignPtr a -> m ()
finalizeForeignPtr (HermesEnv -> ForeignPtr SIMDDocument
hDocument HermesEnv
hEnv)
forall (m :: * -> *) a. MonadIO m => ForeignPtr a -> m ()
finalizeForeignPtr (HermesEnv -> ForeignPtr SIMDParser
hParser HermesEnv
hEnv)
withHermesEnv :: MonadUnliftIO m => (HermesEnv -> m a) -> m a
withHermesEnv :: forall (m :: * -> *) a.
MonadUnliftIO m =>
(HermesEnv -> m a) -> m a
withHermesEnv = forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m HermesEnv
acquire HermesEnv -> m ()
release
where
acquire :: m HermesEnv
acquire = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO HermesEnv
mkHermesEnv_
release :: HermesEnv -> m ()
release = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. HermesEnv -> IO ()
cleanupHermesEnv
data HermesException =
SIMDException DocumentError
| InternalException DocumentError
deriving stock (HermesException -> HermesException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HermesException -> HermesException -> Bool
$c/= :: HermesException -> HermesException -> Bool
== :: HermesException -> HermesException -> Bool
$c== :: HermesException -> HermesException -> Bool
Eq, Int -> HermesException -> ShowS
[HermesException] -> ShowS
HermesException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HermesException] -> ShowS
$cshowList :: [HermesException] -> ShowS
show :: HermesException -> String
$cshow :: HermesException -> String
showsPrec :: Int -> HermesException -> ShowS
$cshowsPrec :: Int -> HermesException -> ShowS
Show, forall x. Rep HermesException x -> HermesException
forall x. HermesException -> Rep HermesException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HermesException x -> HermesException
$cfrom :: forall x. HermesException -> Rep HermesException x
Generic)
instance Exception HermesException
instance NFData HermesException
data DocumentError =
DocumentError
{ DocumentError -> Text
path :: !Text
, DocumentError -> Text
errorMsg :: !Text
, DocumentError -> Text
docLocation :: !Text
, DocumentError -> Text
docDebug :: !Text
}
deriving stock (DocumentError -> DocumentError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocumentError -> DocumentError -> Bool
$c/= :: DocumentError -> DocumentError -> Bool
== :: DocumentError -> DocumentError -> Bool
$c== :: DocumentError -> DocumentError -> Bool
Eq, Int -> DocumentError -> ShowS
[DocumentError] -> ShowS
DocumentError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DocumentError] -> ShowS
$cshowList :: [DocumentError] -> ShowS
show :: DocumentError -> String
$cshow :: DocumentError -> String
showsPrec :: Int -> DocumentError -> ShowS
$cshowsPrec :: Int -> DocumentError -> ShowS
Show, forall x. Rep DocumentError x -> DocumentError
forall x. DocumentError -> Rep DocumentError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DocumentError x -> DocumentError
$cfrom :: forall x. DocumentError -> Rep DocumentError x
Generic)
instance NFData DocumentError
mkDocumentError :: Text -> Text -> Text -> Text -> DocumentError
mkDocumentError :: Text -> Text -> Text -> Text -> DocumentError
mkDocumentError Text
pth Text
msg Text
locStr Text
debugStr = Text -> Text -> Text -> Text -> DocumentError
DocumentError Text
pth Text
msg (Int -> Text -> Text
T.take Int
20 Text
locStr) Text
debugStr
typePrefix :: Text -> Text
typePrefix :: Text -> Text
typePrefix Text
typ = Text
"Error while getting value of type " forall a. Semigroup a => a -> a -> a
<> Text
typ forall a. Semigroup a => a -> a -> a
<> Text
". "
throwSIMD :: SIMDErrorCode -> Text -> Decoder a
throwSIMD :: forall a. SIMDErrorCode -> Text -> Decoder a
throwSIMD SIMDErrorCode
errCode Text
msg = do
Text
pth <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HermesEnv -> Text
hPath
if SIMDErrorCode
errCode forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
[ SIMDErrorCode
EMPTY
, SIMDErrorCode
INSUFFICIENT_PADDING
, SIMDErrorCode
SCALAR_DOCUMENT_AS_VALUE
, SIMDErrorCode
UTF8_ERROR
, SIMDErrorCode
UNCLOSED_STRING
, SIMDErrorCode
UNESCAPED_CHARS
]
then
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentError -> HermesException
SIMDException forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text -> Text -> DocumentError
mkDocumentError Text
pth Text
msg Text
"" Text
""
else do
forall a. (Document -> Decoder a) -> Decoder a
withDocumentPointer forall a b. (a -> b) -> a -> b
$ \Document
docPtr -> do
(Text
locTxt, Text
debugTxt) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Document -> IO (Text, Text)
getDocumentInfo Document
docPtr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentError -> HermesException
SIMDException forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text -> Text -> DocumentError
mkDocumentError Text
pth Text
msg Text
locTxt Text
debugTxt
throwHermes :: Text -> Decoder a
throwHermes :: forall a. Text -> Decoder a
throwHermes Text
msg = do
Text
pth <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HermesEnv -> Text
hPath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentError -> HermesException
InternalException forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text -> Text -> DocumentError
mkDocumentError Text
pth Text
msg Text
"" Text
""
handleErrorCode :: Text -> CInt -> Decoder ()
handleErrorCode :: Text -> CInt -> Decoder ()
handleErrorCode Text
pre CInt
errInt = do
let errCode :: SIMDErrorCode
errCode = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
errInt
if SIMDErrorCode
errCode forall a. Eq a => a -> a -> Bool
== SIMDErrorCode
SUCCESS
then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
String
errStr <- forall (m :: * -> *). MonadIO m => CString -> m String
peekCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CInt -> IO CString
getErrorMessageImpl CInt
errInt)
forall a. SIMDErrorCode -> Text -> Decoder a
throwSIMD SIMDErrorCode
errCode forall a b. (a -> b) -> a -> b
$ Text
pre forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
errStr
{-# INLINE handleErrorCode #-}
withParserPointer :: (Parser -> Decoder a) -> Decoder a
withParserPointer :: forall a. (Parser -> Decoder a) -> Decoder a
withParserPointer Parser -> Decoder a
f =
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HermesEnv -> ForeignPtr SIMDParser
hParser forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ForeignPtr SIMDParser
parserFPtr -> forall (m :: * -> *) a b.
MonadUnliftIO m =>
ForeignPtr a -> (Ptr a -> m b) -> m b
withForeignPtr ForeignPtr SIMDParser
parserFPtr forall a b. (a -> b) -> a -> b
$ Parser -> Decoder a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr SIMDParser -> Parser
Parser
{-# INLINE withParserPointer #-}
withDocumentPointer :: (Document -> Decoder a) -> Decoder a
withDocumentPointer :: forall a. (Document -> Decoder a) -> Decoder a
withDocumentPointer Document -> Decoder a
f =
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HermesEnv -> ForeignPtr SIMDDocument
hDocument forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ForeignPtr SIMDDocument
docFPtr -> forall (m :: * -> *) a b.
MonadUnliftIO m =>
ForeignPtr a -> (Ptr a -> m b) -> m b
withForeignPtr ForeignPtr SIMDDocument
docFPtr forall a b. (a -> b) -> a -> b
$ Document -> Decoder a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr SIMDDocument -> Document
Document
{-# INLINE withDocumentPointer #-}
allocaValue :: (Value -> Decoder a) -> Decoder a
allocaValue :: forall a. (Value -> Decoder a) -> Decoder a
allocaValue Value -> Decoder a
f = forall (m :: * -> *) a b.
MonadUnliftIO m =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
24 forall a b. (a -> b) -> a -> b
$ \Ptr JSONValue
val -> Value -> Decoder a
f (Ptr JSONValue -> Value
Value Ptr JSONValue
val)
{-# INLINE allocaValue #-}
allocaObject :: (Object -> Decoder a) -> Decoder a
allocaObject :: forall a. (Object -> Decoder a) -> Decoder a
allocaObject Object -> Decoder a
f = forall (m :: * -> *) a b.
MonadUnliftIO m =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
24 forall a b. (a -> b) -> a -> b
$ \Ptr JSONObject
objPtr -> Object -> Decoder a
f (Ptr JSONObject -> Object
Object Ptr JSONObject
objPtr)
{-# INLINE allocaObject #-}
allocaArray :: (Array -> Decoder a) -> Decoder a
allocaArray :: forall a. (Array -> Decoder a) -> Decoder a
allocaArray Array -> Decoder a
f = forall (m :: * -> *) a b.
MonadUnliftIO m =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
24 forall a b. (a -> b) -> a -> b
$ \Ptr JSONArray
arr -> Array -> Decoder a
f (Ptr JSONArray -> Array
Array Ptr JSONArray
arr)
{-# INLINE allocaArray #-}
allocaArrayIter :: (ArrayIter -> Decoder a) -> Decoder a
allocaArrayIter :: forall a. (ArrayIter -> Decoder a) -> Decoder a
allocaArrayIter ArrayIter -> Decoder a
f = forall (m :: * -> *) a b.
MonadUnliftIO m =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
24 forall a b. (a -> b) -> a -> b
$ \Ptr JSONArrayIter
iter -> ArrayIter -> Decoder a
f (Ptr JSONArrayIter -> ArrayIter
ArrayIter Ptr JSONArrayIter
iter)
{-# INLINE allocaArrayIter #-}
allocaObjectIter :: (ObjectIter -> Decoder a) -> Decoder a
allocaObjectIter :: forall a. (ObjectIter -> Decoder a) -> Decoder a
allocaObjectIter ObjectIter -> Decoder a
f = forall (m :: * -> *) a b.
MonadUnliftIO m =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
24 forall a b. (a -> b) -> a -> b
$ \Ptr JSONObjectIter
iter -> ObjectIter -> Decoder a
f (Ptr JSONObjectIter -> ObjectIter
ObjectIter Ptr JSONObjectIter
iter)
{-# INLINE allocaObjectIter #-}