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

module Data.Hermes.Decoder.Internal
  ( Decoder(..)
  , HermesEnv(..)
  , HermesException(..)
  , DocumentError(..)
  , withHermesEnv
  , allocaArray
  , allocaArrayIter
  , allocaObject
  , allocaObjectIter
  , allocaValue
  , typePrefix
  , handleErrorCode
  , withParserPointer
  , withDocumentPointer
  , liftIO
  , withRunInIO
  ) where

import           Control.Applicative (Alternative(..))
import           Control.DeepSeq (NFData)
import           Control.Exception (Exception, bracket, catch, throwIO)
import           Control.Monad.Reader (MonadReader, asks)
import           Control.Monad.Trans.Class (lift)
import           Control.Monad.Trans.Reader (ReaderT(..))
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Foreign.C as F
import qualified Foreign.ForeignPtr as F
import qualified Foreign.Marshal.Alloc as F
import qualified Foreign.Ptr as F
import           GHC.Generics (Generic)

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 have no access to the underlying IO, since this could allow decoders to launch nukes.
-- 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
    , MonadReader HermesEnv
    )

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 = forall b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. Decoder a -> IO a
u -> forall a. Decoder a -> IO a
u Decoder a
ad forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(HermesException
_err :: HermesException) -> forall a. Decoder a -> IO a
u 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   :: !(F.ForeignPtr SIMDParser)
    , HermesEnv -> ForeignPtr SIMDDocument
hDocument :: !(F.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 a. ForeignPtr a -> IO ()
F.finalizeForeignPtr (HermesEnv -> ForeignPtr SIMDDocument
hDocument HermesEnv
hEnv)
  forall a. ForeignPtr a -> IO ()
F.finalizeForeignPtr (HermesEnv -> ForeignPtr SIMDParser
hParser HermesEnv
hEnv)

-- | Run an action in IO that is passed a `HermesEnv`.
withHermesEnv :: (HermesEnv -> IO a) -> IO a
withHermesEnv :: forall a. (HermesEnv -> IO a) -> IO a
withHermesEnv = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO HermesEnv
acquire HermesEnv -> IO ()
release
  where
    acquire :: IO HermesEnv
acquire = IO HermesEnv
mkHermesEnv_
    release :: HermesEnv -> IO ()
release = 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 a. IO a -> Decoder a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO 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 a. IO a -> Decoder a
liftIO forall a b. (a -> b) -> a -> b
$ Document -> IO (Text, Text)
getDocumentInfo Document
docPtr
      forall a. IO a -> Decoder a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO 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 a. IO a -> Decoder a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO 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 -> F.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 a. IO a -> Decoder a
liftIO forall a b. (a -> b) -> a -> b
$ CString -> IO String
F.peekCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. Decoder a -> IO a
u -> forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
F.withForeignPtr ForeignPtr SIMDParser
parserFPtr forall a b. (a -> b) -> a -> b
$ forall a. Decoder a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. Decoder a -> IO a
u -> forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
F.withForeignPtr ForeignPtr SIMDDocument
docFPtr forall a b. (a -> b) -> a -> b
$ forall a. Decoder a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 a b. Int -> (Ptr a -> Decoder b) -> Decoder 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 a b. Int -> (Ptr a -> Decoder b) -> Decoder 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 a b. Int -> (Ptr a -> Decoder b) -> Decoder 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 a b. Int -> (Ptr a -> Decoder b) -> Decoder 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 a b. Int -> (Ptr a -> Decoder b) -> Decoder 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 #-}

allocaBytes :: Int -> (F.Ptr a -> Decoder b) -> Decoder b
allocaBytes :: forall a b. Int -> (Ptr a -> Decoder b) -> Decoder b
allocaBytes Int
size Ptr a -> Decoder b
action = forall b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
withRunInIO (\forall a. Decoder a -> IO a
u -> forall a b. Int -> (Ptr a -> IO b) -> IO b
F.allocaBytes Int
size (forall a. Decoder a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> Decoder b
action))
{-# INLINE allocaBytes #-}

withRunInIO :: ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
withRunInIO :: forall b. ((forall a. Decoder a -> IO a) -> IO b) -> Decoder b
withRunInIO (forall a. Decoder a -> IO a) -> IO b
inner =
  forall a. ReaderT HermesEnv IO a -> Decoder a
Decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \HermesEnv
r ->
    (forall a. Decoder a -> IO a) -> IO b
inner (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT HermesEnv
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Decoder a -> ReaderT HermesEnv IO a
runDecoder)
{-# INLINE withRunInIO #-}

liftIO :: IO a -> Decoder a
liftIO :: forall a. IO a -> Decoder a
liftIO = forall a. ReaderT HermesEnv IO a -> Decoder a
Decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
{-# INLINE liftIO #-}