Value.hs

{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}

module Data.Hermes.Decoder.Value
  ( atKey
  , atKeyOptional
  , atKeyStrict
  , atPointer
  , bool
  , char
  , double
  , int
  , uint
  , getType
  , list
  , nullable
  , object
  , objectAsKeyValues
  , objectAsMap
  , parseScientific
  , scientific
  , string
  , text
  , listOfDouble
  , listOfInt
  , isNull
  , vector
  , withBool
  , withDouble
  , withInt
  , withObjectAsMap
  , withRawByteString
  , withRawText
  , withScientific
  , withString
  , withText
  , withType
  , withVector
  ) where

import           Control.Monad ((>=>))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as Unsafe
import qualified Data.DList as DList
import           Data.Map (Map)
import qualified Data.Map.Strict as M
import qualified Data.Scientific as Sci
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Foreign as T
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as GM
import qualified Foreign.C.String as F
import qualified Foreign.ForeignPtr as F
import qualified Foreign.Marshal.Alloc as F
import qualified Foreign.Marshal.Array as F
import qualified Foreign.Marshal.Utils as F
import qualified Foreign.Ptr as F
import qualified Foreign.Storable as F

import           Data.Hermes.Decoder.Internal
import           Data.Hermes.Decoder.Internal.Scientific
import           Data.Hermes.Decoder.Path
import           Data.Hermes.SIMDJSON

-- | Decode a value at the particular JSON pointer following RFC 6901.
-- Be careful where you use this because it rewinds the document on each
-- successive call.
--
-- > decodeEither (atPointer "/statuses/99" decodeObject) input
atPointer :: Text -> Decoder a -> Decoder a
atPointer jptr (Decoder f) = Decoder $ \_ -> do
  doc <- asks hDocument
  withRunInIO $ \run ->
    F.withForeignPtr doc $ \docPtr ->
      Unsafe.unsafeUseAsCStringLen (T.encodeUtf8 jptr) $ \(cstr, len) ->
        allocaValue $ \vPtr -> run . withPointer jptr $ do
          err <- liftIO $ atPointerImpl cstr len (Document docPtr) vPtr
          handleErrorCode "" err
          f vPtr
{-# INLINE atPointer #-}

-- | Enter an `Object` to begin parsing its fields.
object :: FieldsDecoder a -> Decoder a
object f = Decoder $ \(Value valPtr) ->
  withRunInIO $ \run ->
    allocaValue $ \vPtr -> do
      err <- getObjectFromValueImpl (Value valPtr)
      run $ do
        handleErrorCode (typePrefix "object") err
        runDecoder (runFieldsDecoder f . Object $ F.castPtr valPtr) vPtr
{-# INLINE object #-}

-- | Helper to work with an Int parsed from a Value.
withInt :: (Int -> Decoder a) -> Decoder a
withInt f = Decoder $ \val -> getInt val >>= \i -> runDecoder (f i) val
{-# INLINE withInt #-}

-- | Helper to work with a Double parsed from a Value.
withDouble :: (Double -> Decoder a) -> Decoder a
withDouble f = Decoder $ \val -> getDouble val >>= \d -> runDecoder (f d) val
{-# INLINE withDouble #-}

-- | Helper to work with a Bool parsed from a Value.
withBool :: (Bool -> Decoder a) -> Decoder a
withBool f = Decoder $ \val -> getBool val >>= \b -> runDecoder (f b) val
{-# INLINE withBool #-}

-- | Helper to work with the raw ByteString of the JSON token parsed from the given Value.
withRawByteString :: (BS.ByteString -> Decoder a) -> Decoder a
withRawByteString f = Decoder $ \val -> getRawByteString val >>= \b -> runDecoder (f b) val
{-# INLINE withRawByteString #-}

-- | Helper to work with the raw ByteString of the JSON token parsed from the given Value.
withRawText :: (Text -> Decoder a) -> Decoder a
withRawText f = Decoder $ \val -> getRawText val >>= \b -> runDecoder (f b) val
{-# INLINE withRawText #-}

-- | Helper to work with a String parsed from a Value.
withString :: (String -> Decoder a) -> Decoder a
withString f = Decoder $ \val -> getString val >>= \s -> runDecoder (f s) val
{-# INLINE withString #-}

-- | Helper to work with a Text parsed from a Value.
withText :: (Text -> Decoder a) -> Decoder a
withText f = Decoder $ \val -> getText val >>= \t -> runDecoder (f t) val
{-# INLINE withText #-}

-- | Returns True if the Value is null.
isNull :: Decoder Bool
isNull = Decoder $ \valPtr ->
  withRunInIO $ \run ->
    F.alloca $ \ptr -> do
      err <- isNullImpl valPtr ptr
      run $ do
        handleErrorCode "" err
        fmap F.toBool . liftIO $ F.peek ptr
{-# INLINE isNull #-}

-- | Is more efficient by looping in C++ instead of Haskell.
listOfInt :: Decoder [Int]
listOfInt =
  withArrayLen $ \(arrPtr, len) ->
    withRunInIO $ \run ->
      F.allocaArray len $ \out -> do
        err <- intArrayImpl arrPtr out
        run $ handleErrorCode "Error decoding array of ints." err
        F.peekArray len out
{-# RULES "list int/listOfInt" list int = listOfInt #-}

-- | Is more efficient by looping in C++ instead of Haskell.
listOfDouble :: Decoder [Double]
listOfDouble =
  withArrayLen $ \(arrPtr, len) ->
    withRunInIO $ \run ->
      F.allocaArray len $ \out -> do
        err <- doubleArrayImpl arrPtr out
        run $ handleErrorCode "Error decoding array of doubles." err
        F.peekArray len out
{-# RULES "list double/listOfDouble" list double = listOfDouble #-}

-- | Find an object field by key, where an exception is thrown
-- if the key is missing.
atKey :: Text -> Decoder a -> FieldsDecoder a
atKey key parser =
  FieldsDecoder $ \obj -> Decoder $ \val -> withUnorderedField val parser obj key
{-# INLINE atKey #-}

-- | Find an object field by key, where Nothing is returned
-- if the key is missing.
atKeyOptional :: Text -> Decoder a -> FieldsDecoder (Maybe a)
atKeyOptional key parser =
  FieldsDecoder $ \obj -> Decoder $ \val -> withUnorderedOptionalField val parser obj key
{-# INLINE atKeyOptional #-}

-- | Uses find_field, which means if you access a field out-of-order
-- this will throw an exception. It also cannot support optional fields.
atKeyStrict :: Text -> Decoder a -> FieldsDecoder a
atKeyStrict key parser =
  FieldsDecoder $ \obj -> Decoder $ \val -> withField val parser obj key
{-# INLINE atKeyStrict #-}

-- | Parse a homogenous JSON array into a Haskell list.
list :: Decoder a -> Decoder [a]
list f = withArrayIter $ iterateOverArray f
{-# INLINE[2] list #-}

-- | Parse a homogenous JSON array into a generic `Vector`.
vector :: G.Vector v a => Decoder a -> Decoder (v a)
vector f = withArrayLenIter $ iterateOverArrayLen f
{-# INLINE vector #-}

withVector :: G.Vector v a => Decoder a -> (v a -> Decoder a) -> Decoder a
withVector inner f = Decoder $ \val -> runDecoder (vector inner) val >>= \v -> runDecoder (f v) val
{-# INLINE withVector #-}

-- | Parse an object into a homogenous list of key-value tuples.
objectAsKeyValues
  :: (Text -> Decoder k)
  -- ^ Parses a Text key in the Decoder monad. JSON keys are always text.
  -> Decoder v
  -- ^ Decoder for the field value.
  -> Decoder [(k, v)]
objectAsKeyValues kf vf = withObjectIter $ iterateOverFields kf vf
{-# INLINE objectAsKeyValues #-}

-- | Parse an object into a strict `Map`.
objectAsMap
  :: Ord k
  => (Text -> Decoder k)
  -- ^ Parses a Text key in the Decoder monad. JSON keys are always text.
  -> Decoder v
  -- ^ Decoder for the field value.
  -> Decoder (Map k v)
objectAsMap kf vf = withObjectIter $ iterateOverFieldsMap kf vf
{-# INLINE objectAsMap #-}

withObjectAsMap
  :: Ord k
  => (Text -> Decoder k)
  -- ^ Parses a Text key in the Decoder monad. JSON keys are always text.
  -> Decoder v
  -- ^ Decoder for the field value.
  -> (Map k v -> Decoder a)
  -> Decoder a
withObjectAsMap kf vf f = Decoder $ \val -> runDecoder (objectAsMap kf vf) val >>= \m -> runDecoder (f m) val
{-# INLINE withObjectAsMap #-}

-- | Transforms a parser to return Nothing when the value is null.
nullable :: Decoder a -> Decoder (Maybe a)
nullable parser = Decoder $ \val -> do
  nil <- runDecoder isNull val
  if nil
    then pure Nothing
    else Just <$> runDecoder parser val
{-# INLINE nullable #-}

-- | Parse only a single character.
char :: Decoder Char
char = Decoder $ getText >=> justOne
  where
    justOne txt =
      case T.uncons txt of
        Just (c, "") ->
          pure c
        _ ->
          fail "Expected a single character"
{-# INLINE char #-}

-- | Parse a JSON string into a Haskell String.
-- For best performance you should use `text` instead.
string :: Decoder String
string = Decoder getString
{-# INLINE string #-}

-- | Parse a JSON string into Haskell Text.
text :: Decoder Text
text = Decoder getText
{-# INLINE text #-}

-- | Parse a JSON boolean into a Haskell Bool.
bool :: Decoder Bool
bool = Decoder getBool
{-# INLINE bool #-}

-- | Parse a JSON number into a signed Haskell Int.
int :: Decoder Int
int = Decoder getInt
{-# INLINE[2] int #-}

-- | Parse a JSON number into an unsigned Haskell Int (Word).
uint :: Decoder Word
uint = Decoder getUInt
{-# INLINE uint #-}

-- | Parse a JSON number into a Haskell Double.
double :: Decoder Double
double = Decoder getDouble
{-# INLINE[2] double #-}

-- | Parse a Scientific from a Value.
scientific :: Decoder Sci.Scientific
scientific = withRawText parseScientific
{-# INLINE scientific #-}

withScientific :: (Sci.Scientific -> Decoder a) -> Decoder a
withScientific f = Decoder $ \val -> runDecoder scientific val >>= \sci -> runDecoder (f sci) val
{-# INLINE withScientific #-}

-- | Parse a Scientific from UTF-8 text.
parseScientific :: Text -> Decoder Sci.Scientific
parseScientific = scanScientific
    (\sci rest -> if T.null rest then return sci else fail $ "Expecting end-of-input, got " ++ show (T.take 10 rest))
    fail
{-# INLINE parseScientific #-}

-- | Get the simdjson type of the Value.
getType :: Decoder ValueType
getType =
  Decoder $ \valPtr ->
    withRunInIO $ \run ->
      F.alloca $ \ptr -> do
        err <- getTypeImpl valPtr ptr
        run $ do
          handleErrorCode "" err
          fmap (toEnum . fromIntegral) . liftIO $ F.peek ptr
{-# INLINE getType #-}

withType :: (ValueType -> Decoder a) -> Decoder a
withType f = Decoder $ \val -> runDecoder getType val >>= \ty -> runDecoder (f ty) val
{-# INLINE withType #-}

-- Internal Functions

-- | Helper to work with an ArrayIter started from a Value assumed to be an Array.
withArrayIter :: (ArrayIter -> DecoderM a) -> Decoder a
withArrayIter f = Decoder $ \(Value valPtr) ->
  withRunInIO $ \run -> do
    err <- getArrayIterFromValueImpl (Value valPtr)
    run $ do
      handleErrorCode (typePrefix "array") err
      f (ArrayIter $ F.castPtr valPtr)
{-# INLINE withArrayIter #-}

-- | Execute a function on each Value in an ArrayIter and
-- accumulate the results into a list.
iterateOverArray :: Decoder a -> ArrayIter -> DecoderM [a]
iterateOverArray f iterPtr =
  withRunInIO $ \run ->
    allocaValue $ \valPtr -> run $ go (0 :: Int) DList.empty valPtr
  where
    go !n acc valPtr = do
      isOver <- fmap F.toBool . liftIO $ arrayIterIsDoneImpl iterPtr
      if not isOver
        then do
          r <- withIndex n $ do
            err <- liftIO $ arrayIterGetCurrentImpl iterPtr valPtr
            handleErrorCode "" err
            result <- runDecoder f valPtr
            liftIO $ arrayIterMoveNextImpl iterPtr
            pure result
          go (n + 1) (acc <> DList.singleton r) valPtr
        else
          pure $ DList.toList acc
{-# INLINE iterateOverArray #-}

-- | Helper to work with an ArrayIter and its length.
withArrayLenIter :: (ArrayIter -> Int -> DecoderM a) -> Decoder a
withArrayLenIter f = Decoder $ \(Value valPtr) ->
  withRunInIO $ \run -> do
    F.alloca $ \outLen -> do
      err <- getArrayIterLenFromValueImpl (Value valPtr) outLen
      len <- fmap fromIntegral $ F.peek outLen
      run $ do
        handleErrorCode "" err
        f (ArrayIter $ F.castPtr valPtr) len
{-# INLINE withArrayLenIter #-}

-- | Execute a function on each Value in an ArrayIter and
-- accumulate the results into a generic `Vector`.
iterateOverArrayLen :: G.Vector v a => Decoder a -> ArrayIter -> Int -> DecoderM (v a)
iterateOverArrayLen f iterPtr len =
  withRunInIO $ \run ->
    allocaValue $ \valPtr -> do
      v <- GM.new len
      _ <- run . runDecoderPrimM $ go (0 :: Int) v valPtr
      G.unsafeFreeze v
  where
    go !n acc valPtr = do
      isOver <- fmap F.toBool . DecoderPrimM . liftIO $ arrayIterIsDoneImpl iterPtr
      if not isOver
        then do
          _ <- DecoderPrimM . withIndex n . runDecoderPrimM $ do
            err <- DecoderPrimM . liftIO $ arrayIterGetCurrentImpl iterPtr valPtr
            DecoderPrimM $ handleErrorCode "" err
            !result <- DecoderPrimM $ runDecoder f valPtr
            DecoderPrimM . liftIO $ arrayIterMoveNextImpl iterPtr
            GM.unsafeWrite acc n result
          go (n + 1) acc valPtr
        else
          pure acc
{-# INLINE iterateOverArrayLen #-}

-- | Helper to work with an ObjectIter started from a Value assumed to be an Object.
withObjectIter :: (ObjectIter -> DecoderM a) -> Decoder a
withObjectIter f = Decoder $ \(Value valPtr) ->
  withRunInIO $ \run -> do
    err <- getObjectIterFromValueImpl (Value valPtr)
    run $ do
      handleErrorCode (typePrefix "object") err
      f (ObjectIter $ F.castPtr valPtr)
{-# INLINE withObjectIter #-}

-- | Execute a function on each Field in an ObjectIter and accumulate into a `Map`.
iterateOverFieldsMap
  :: Ord a
  => (Text -> Decoder a)
  -> Decoder b
  -> ObjectIter
  -> DecoderM (Map a b)
iterateOverFieldsMap fk fv iterPtr =
  withRunInIO $ \run ->
    F.alloca $ \lenPtr ->
      F.alloca $ \keyPtr ->
        allocaValue $ \valPtr -> run $ go M.empty keyPtr lenPtr valPtr
  where
    go !acc keyPtr lenPtr valPtr = do
      isOver <- fmap F.toBool . liftIO $ objectIterIsDoneImpl iterPtr
      if not isOver
        then do
          err <- liftIO $ objectIterGetCurrentImpl iterPtr keyPtr lenPtr valPtr
          handleErrorCode "" err
          kLen <- fmap fromIntegral . liftIO $ F.peek lenPtr
          kStr <- liftIO $ F.peek keyPtr
          keyTxt <- parseTextFromCStrLen (kStr, kLen)
          (k, v)
            <-
              withKey keyTxt $ do
                k <- runDecoder (fk keyTxt) valPtr
                v <- runDecoder fv valPtr
                pure (k, v)
          liftIO $ objectIterMoveNextImpl iterPtr
          go (M.insert k v acc) keyPtr lenPtr valPtr
        else
          pure acc
{-# INLINE iterateOverFieldsMap #-}

-- | Execute a function on each Field in an ObjectIter and
-- accumulate key-value tuples into a list.
iterateOverFields
  :: (Text -> Decoder a)
  -> Decoder b
  -> ObjectIter
  -> DecoderM [(a, b)]
iterateOverFields fk fv iterPtr =
  withRunInIO $ \run ->
    F.alloca $ \lenPtr ->
      F.alloca $ \keyPtr ->
        allocaValue $ \valPtr -> run $ go DList.empty keyPtr lenPtr valPtr
  where
    go acc keyPtr lenPtr valPtr = do
      isOver <- fmap F.toBool . liftIO $ objectIterIsDoneImpl iterPtr
      if not isOver
        then do
          err <- liftIO $ objectIterGetCurrentImpl iterPtr keyPtr lenPtr valPtr
          handleErrorCode "" err
          kLen <- fmap fromIntegral . liftIO $ F.peek lenPtr
          kStr <- liftIO $ F.peek keyPtr
          keyTxt <- parseTextFromCStrLen (kStr, kLen)
          kv <-
            withKey keyTxt $ do
              k <- runDecoder (fk keyTxt) valPtr
              v <- runDecoder fv valPtr
              pure (k, v)
          liftIO $ objectIterMoveNextImpl iterPtr
          go (acc <> DList.singleton kv) keyPtr lenPtr valPtr
        else
          pure $ DList.toList acc
{-# INLINE iterateOverFields #-}

withUnorderedField :: Value -> Decoder a -> Object -> Text -> DecoderM a
withUnorderedField vPtr f objPtr key =
  withRunInIO $ \run ->
    Unsafe.unsafeUseAsCStringLen (T.encodeUtf8 key) $ \(cstr, len) ->
      run $ withKey key $ do
        err <- liftIO $ findFieldUnorderedImpl objPtr cstr len vPtr
        handleErrorCode "" err
        runDecoder f vPtr
{-# INLINE withUnorderedField #-}

withUnorderedOptionalField :: Value -> Decoder a -> Object -> Text -> DecoderM (Maybe a)
withUnorderedOptionalField vPtr f objPtr key =
  withRunInIO $ \run ->
    Unsafe.unsafeUseAsCStringLen (T.encodeUtf8 key) $ \(cstr, len) ->
      run $ withKey key $ do
        err <- liftIO $ findFieldUnorderedImpl objPtr cstr len vPtr
        let errCode = toEnum $ fromIntegral err
        if | errCode == SUCCESS       -> Just <$> runDecoder f vPtr
           | errCode == NO_SUCH_FIELD -> pure Nothing
           | otherwise                -> Nothing <$ handleErrorCode "" err
{-# INLINE withUnorderedOptionalField #-}

withField :: Value -> Decoder a -> Object -> Text -> DecoderM a
withField vPtr f objPtr key =
  withRunInIO $ \run ->
    Unsafe.unsafeUseAsCStringLen (T.encodeUtf8 key) $ \(cstr, len) ->
      run $ withKey key $ do
        err <- liftIO $ findFieldImpl objPtr cstr len vPtr
        handleErrorCode "" err
        runDecoder f vPtr
{-# INLINE withField #-}

getInt :: Value -> DecoderM Int
getInt valPtr =
  withRunInIO $ \run ->
    F.alloca $ \ptr -> run $ do
      err <- liftIO $ getIntImpl valPtr ptr
      handleErrorCode (typePrefix "int") err
      liftIO $ F.peek ptr
{-# INLINE getInt #-}

getUInt :: Value -> DecoderM Word
getUInt valPtr =
  withRunInIO $ \run ->
    F.alloca $ \ptr -> run $ do
      err <- liftIO $ getUIntImpl valPtr ptr
      handleErrorCode (typePrefix "unsigned int") err
      liftIO $ F.peek ptr
{-# INLINE getUInt #-}

getDouble :: Value -> DecoderM Double
getDouble valPtr =
  withRunInIO $ \run ->
    F.alloca $ \ptr -> run $ do
      err <- liftIO $ getDoubleImpl valPtr ptr
      handleErrorCode (typePrefix "double") err
      liftIO $ F.peek ptr
{-# INLINE getDouble #-}

getBool :: Value -> DecoderM Bool
getBool valPtr =
  withRunInIO $ \run ->
    F.alloca $ \ptr -> run $ do
      err <- liftIO $ getBoolImpl valPtr ptr
      handleErrorCode (typePrefix "bool") err
      fmap F.toBool . liftIO $ F.peek ptr
{-# INLINE getBool #-}

withCStringLen :: Text -> (F.CStringLen -> DecoderM a) -> Value -> DecoderM a
withCStringLen lbl f valPtr =
  withRunInIO $ \run ->
    F.alloca $ \strPtr ->
      F.alloca $ \lenPtr -> run $ do
        err <- liftIO $ getStringImpl valPtr strPtr lenPtr
        handleErrorCode (typePrefix lbl) err
        len <- fmap fromIntegral . liftIO $ F.peek lenPtr
        str <- liftIO $ F.peek strPtr
        f (str, len)
{-# INLINE withCStringLen #-}

getString :: Value -> DecoderM String
getString = withCStringLen "string" (liftIO . F.peekCStringLen)
{-# INLINE getString #-}

getText :: Value -> DecoderM Text
getText = withCStringLen "text" parseTextFromCStrLen
{-# INLINE getText #-}

parseTextFromCStrLen :: F.CStringLen -> DecoderM Text
parseTextFromCStrLen (cstr, len) = liftIO $ T.fromPtr (F.castPtr cstr) (fromIntegral len)
{-# INLINE parseTextFromCStrLen #-}

getRawByteString :: Value -> DecoderM BS.ByteString
getRawByteString valPtr =
  liftIO $
    F.alloca $ \strPtr ->
      F.alloca $ \lenPtr -> do
        getRawJSONTokenImpl valPtr strPtr lenPtr
        len <- fmap fromIntegral $ F.peek lenPtr
        str <- F.peek strPtr
        Unsafe.unsafePackCStringLen (str, len)
{-# INLINE getRawByteString #-}

getRawText :: Value -> DecoderM Text
getRawText valPtr =
  liftIO $
    F.alloca $ \strPtr ->
      F.alloca $ \lenPtr -> do
        getRawJSONTokenImpl valPtr strPtr lenPtr
        len <- fmap fromIntegral $ F.peek lenPtr
        str <- F.peek strPtr
        T.fromPtr (F.castPtr str) len
{-# INLINE getRawText #-}

-- | Helper to work with an Array and its length parsed from a Value.
withArrayLen :: ((Array, Int) -> DecoderM a) -> Decoder a
withArrayLen f = Decoder $ \(Value val) ->
  withRunInIO $ \run ->
    F.alloca $ \outLen -> do
      err <- getArrayLenFromValueImpl (Value val) outLen
      len <- fmap fromIntegral $ F.peek outLen
      run $ do
        handleErrorCode (typePrefix "array") err
        f (Array $ F.castPtr val, len)
{-# INLINE withArrayLen #-}