{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | `Decoder` is the monad used for decoding JSON with simdjson via the FFI.
-- This module contains helpers for working with the `Decoder` context.

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

-- | A Decoder is some context around the IO needed by the C FFI to allocate local memory.
-- Users shouldn't need to deal with the underlying IO except in advanced use cases.
-- Using `Data.Hermes.decodeEither` discharges the IO and returns us to purity,
-- since we know decoding a document is referentially transparent.
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

-- | Contains foreign references to the allocated simdjson::parser
-- and simdjson::document. Also maintains a path string that is updated
-- when an object field or array value is entered and which is displayed in errors.
data HermesEnv =
  HermesEnv
    { HermesEnv -> ForeignPtr SIMDParser
hParser   :: !(ForeignPtr SIMDParser)
    , HermesEnv -> ForeignPtr SIMDDocument
hDocument :: !(ForeignPtr SIMDDocument)
    , HermesEnv -> Text
hPath     :: !Text
    }

-- | Make a new HermesEnv. This allocates foreign references to
-- a simdjson::ondemand::parser and a simdjson::ondemand::document.
-- The optional capacity argument sets the max capacity in bytes for the
-- simdjson::ondemand::parser, which defaults to 4GB.
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
""
    }

-- | Shortcut for constructing a default `HermesEnv`.
mkHermesEnv_ :: IO HermesEnv
mkHermesEnv_ :: IO HermesEnv
mkHermesEnv_ = Maybe Int -> IO HermesEnv
mkHermesEnv forall a. Maybe a
Nothing

-- | Internal finalizer for simdjson instances.
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)

-- | Run an action that is passed a `HermesEnv`.
-- The simdjson instances are created and destroyed using the `bracket` function.
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

-- | The library can throw exceptions from simdjson in addition to
-- its own exceptions.
data HermesException =
    SIMDException DocumentError
    -- ^ An exception thrown from the simdjson library.
  | InternalException DocumentError
    -- ^ An exception thrown from an internal library function.
  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

-- | Record containing all pertinent information for troubleshooting an exception.
data DocumentError =
  DocumentError
    { DocumentError -> Text
path        :: !Text
    -- ^ The path to the current element determined by the decoder.
    -- Formatted in the JSON Pointer standard per RFC 6901.
    , DocumentError -> Text
errorMsg    :: !Text
    -- ^ An error message.
    , DocumentError -> Text
docLocation :: !Text
    -- ^ Truncated location of the simdjson document iterator.
    , DocumentError -> Text
docDebug    :: !Text
    -- ^ Debug information from simdjson::document.
    }
    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
". "

-- | Re-throw an exception caught from the simdjson library.
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

-- | Throw an IO exception in the `Decoder` context.
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
""

-- Foreign helpers

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 #-}