{-|
Module      : Z.Data.JSON.Value
Description : JSON representation and parsers
Copyright   : (c) Dong Han, 2019
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides definition and parsers for JSON 'Value's, a Haskell JSON representation. The parsers is designed to comply with <https://tools.ietf.org/html/rfc8258 rfc8258>, notable pitfalls are:

  * The numeric representation use 'Scientific', which impose a limit on number's exponent part(limited to 'Int').
  * Unescaped control characters(<=0x1F) are NOT accepted, (different from aeson).
  * Only @0x20, 0x09, 0x0A, 0x0D@ are valid JSON whitespaces, 'skipSpaces' from this module is different from 'P.skipSpaces'.
  * A JSON document shouldn't have trailing characters except whitespaces describe above, see 'parseValue''
    and 'parseValueChunks''.
  * Objects are represented as key-value vectors, key order and duplicated keys are preserved for further processing.

Note that rfc8258 doesn't enforce unique key in objects, it's up to users to decided how to deal with key duplication, e.g. prefer first or last key, see 'Z.Data.JSON.Base.withFlatMap' or 'Std.Data.JSON.Base.withFlatMapR' for example.

There's no lazy parsers here, every pieces of JSON document will be parsed into a normal form 'Value'. 'Object' and 'Array's payloads are packed into 'Vector's to avoid accumulating lists in memory. Read more about <http://winterland.me/2019/03/05/aeson's-mysterious-lazy-parsing why no lazy parsing is needed>.
-}

module Z.Data.JSON.Value
  ( -- * Value type
    Value(..)
    -- * parse into JSON Value
  , parseValue
  , parseValue'
  , parseValueChunks
  , parseValueChunks'
    -- * Value Parsers
  , value
  , object
  , array
  , string
  , skipSpaces
  ) where

import           Control.DeepSeq
import           Data.Bits                ((.&.))
import           Data.Functor
import           Data.Scientific          (Scientific, scientific)
import           Data.Typeable
import           Data.Word
import           GHC.Generics
import qualified Z.Data.Parser          as P
import qualified Z.Data.Text.Base       as T
import           Z.Data.Text.Print     (Print(..))
import           Z.Data.Vector.Base     as V
import           Z.Data.Vector.Extra    as V
import           Z.Foreign
import           System.IO.Unsafe         (unsafeDupablePerformIO)
import           Test.QuickCheck.Arbitrary (Arbitrary(..))
import           Test.QuickCheck.Gen (Gen(..), listOf)

#define BACKSLASH 92
#define CLOSE_CURLY 125
#define CLOSE_SQUARE 93
#define COMMA 44
#define COLON 58
#define DOUBLE_QUOTE 34
#define OPEN_CURLY 123
#define OPEN_SQUARE 91
#define C_0 48
#define C_9 57
#define C_A 65
#define C_F 70
#define C_a 97
#define C_f 102
#define C_n 110
#define C_t 116
#define MINUS    45

--------------------------------------------------------------------------------
-- | A JSON value represented as a Haskell value.
--
-- The 'Object''s payload is a key-value vector instead of a map, which parsed
-- directly from JSON document. This design choice has following advantages:
--
--    * Allow different strategies handling duplicated keys.
--    * Allow different 'Map' type to do further parsing, e.g. 'Z.Data.Vector.FlatMap'
--    * Roundtrip without touching the original key-value order.
--    * Save time if constructing map is not neccessary, e.g.
--      using a linear scan to find a key if only that key is needed.
--
data Value = Object {-# UNPACK #-} !(V.Vector (T.Text, Value))
           | Array  {-# UNPACK #-} !(V.Vector Value)
           | String {-# UNPACK #-} !T.Text
           | Number {-# UNPACK #-} !Scientific
           | Bool   !Bool
           | Null
         deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, Eq Value
Eq Value
-> (Value -> Value -> Ordering)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Value)
-> (Value -> Value -> Value)
-> Ord Value
Value -> Value -> Bool
Value -> Value -> Ordering
Value -> Value -> Value
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Value -> Value -> Value
$cmin :: Value -> Value -> Value
max :: Value -> Value -> Value
$cmax :: Value -> Value -> Value
>= :: Value -> Value -> Bool
$c>= :: Value -> Value -> Bool
> :: Value -> Value -> Bool
$c> :: Value -> Value -> Bool
<= :: Value -> Value -> Bool
$c<= :: Value -> Value -> Bool
< :: Value -> Value -> Bool
$c< :: Value -> Value -> Bool
compare :: Value -> Value -> Ordering
$ccompare :: Value -> Value -> Ordering
$cp1Ord :: Eq Value
Ord, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Typeable, (forall x. Value -> Rep Value x)
-> (forall x. Rep Value x -> Value) -> Generic Value
forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Value x -> Value
$cfrom :: forall x. Value -> Rep Value x
Generic)
         deriving anyclass Int -> Value -> Builder ()
(Int -> Value -> Builder ()) -> Print Value
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> Value -> Builder ()
$ctoUTF8BuilderP :: Int -> Value -> Builder ()
Print

instance NFData Value where
    {-# INLINE rnf #-}
    rnf :: Value -> ()
rnf (Object Vector (Text, Value)
o) = Vector (Text, Value) -> ()
forall a. NFData a => a -> ()
rnf Vector (Text, Value)
o
    rnf (Array  Vector Value
a) = Vector Value -> ()
forall a. NFData a => a -> ()
rnf Vector Value
a
    rnf (String Text
s) = Text -> ()
forall a. NFData a => a -> ()
rnf Text
s
    rnf (Number Scientific
n) = Scientific -> ()
forall a. NFData a => a -> ()
rnf Scientific
n
    rnf (Bool   Bool
b) = Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
b
    rnf Value
Null = ()

instance Arbitrary Value where
    -- limit maximum depth of JSON document, otherwise it's too slow to run any tests
    arbitrary :: Gen Value
arbitrary = Int -> Int -> Gen Value
arbitraryValue Int
0 Int
4
      where
        arbitraryValue :: Int -> Int -> Gen Value
        arbitraryValue :: Int -> Int -> Gen Value
arbitraryValue Int
d Int
s = do
            Word
i <- Gen Word
forall a. Arbitrary a => Gen a
arbitrary :: Gen Word
            case (Word
i Word -> Word -> Word
forall a. Integral a => a -> a -> a
`mod` Word
6) of
                Word
0 -> if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
s then Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> ([(Text, Value)] -> Vector (Text, Value))
-> [(Text, Value)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Vector (Text, Value)
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack ([(Text, Value)] -> Value) -> Gen [(Text, Value)] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Text, Value) -> Gen [(Text, Value)]
forall a. Gen a -> Gen [a]
listOf (Int -> Int -> Gen (Text, Value)
forall a. Arbitrary a => Int -> Int -> Gen (a, Value)
arbitraryKV (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
s)
                              else Value -> Gen Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
                Word
1 -> if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
s then Vector Value -> Value
Array (Vector Value -> Value)
-> ([Value] -> Vector Value) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack ([Value] -> Value) -> Gen [Value] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Value -> Gen [Value]
forall a. Gen a -> Gen [a]
listOf (Int -> Int -> Gen Value
arbitraryValue (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
s)
                              else Value -> Gen Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
                Word
2 -> Text -> Value
String (Text -> Value) -> Gen Text -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall a. Arbitrary a => Gen a
arbitrary
                Word
3 -> do
                    Integer
c <- Gen Integer
forall a. Arbitrary a => Gen a
arbitrary
                    Int
e <- Gen Int
forall a. Arbitrary a => Gen a
arbitrary
                    Value -> Gen Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value)
-> (Scientific -> Value) -> Scientific -> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
Number (Scientific -> Gen Value) -> Scientific -> Gen Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Scientific
scientific Integer
c Int
e
                Word
4 -> Bool -> Value
Bool (Bool -> Value) -> Gen Bool -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
                Word
_ -> Value -> Gen Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null

        arbitraryKV :: Int -> Int -> Gen (a, Value)
arbitraryKV Int
d Int
s = (,) (a -> Value -> (a, Value)) -> Gen a -> Gen (Value -> (a, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary Gen (Value -> (a, Value)) -> Gen Value -> Gen (a, Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Int -> Gen Value
arbitraryValue Int
d Int
s

    shrink :: Value -> [Value]
shrink (Object Vector (Text, Value)
kvs) = (Text, Value) -> Value
forall a b. (a, b) -> b
snd ((Text, Value) -> Value) -> [(Text, Value)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Text, Value)
kvs)
    shrink (Array Vector Value
vs) = Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs
    shrink Value
_          = []

-- | Parse 'Value' without consuming trailing bytes.
parseValue :: V.Bytes -> (V.Bytes, Either P.ParseError Value)
{-# INLINE parseValue #-}
parseValue :: Bytes -> (Bytes, Either ParseError Value)
parseValue = Parser Value -> Bytes -> (Bytes, Either ParseError Value)
forall a. Parser a -> Bytes -> (Bytes, Either ParseError a)
P.parse Parser Value
value

-- | Parse 'Value', and consume all trailing JSON white spaces, if there're
-- bytes left, parsing will fail.
parseValue' :: V.Bytes -> Either P.ParseError Value
{-# INLINE parseValue' #-}
parseValue' :: Bytes -> Either ParseError Value
parseValue' = Parser Value -> Bytes -> Either ParseError Value
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser Value
value Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput)

-- | Increamental parse 'Value' without consuming trailing bytes.
parseValueChunks :: Monad m => m V.Bytes -> V.Bytes -> m (V.Bytes, Either P.ParseError Value)
{-# INLINE parseValueChunks #-}
parseValueChunks :: m Bytes -> Bytes -> m (Bytes, Either ParseError Value)
parseValueChunks = Parser Value
-> m Bytes -> Bytes -> m (Bytes, Either ParseError Value)
forall (m :: * -> *) a.
Monad m =>
Parser a -> ParseChunks m Bytes ParseError a
P.parseChunks Parser Value
value

-- | Increamental parse 'Value' and consume all trailing JSON white spaces, if there're
-- bytes left, parsing will fail.
parseValueChunks' :: Monad m => m V.Bytes -> V.Bytes -> m (Either P.ParseError Value)
{-# INLINE parseValueChunks' #-}
parseValueChunks' :: m Bytes -> Bytes -> m (Either ParseError Value)
parseValueChunks' m Bytes
mi Bytes
inp = (Bytes, Either ParseError Value) -> Either ParseError Value
forall a b. (a, b) -> b
snd ((Bytes, Either ParseError Value) -> Either ParseError Value)
-> m (Bytes, Either ParseError Value)
-> m (Either ParseError Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Value -> ParseChunks m Bytes ParseError Value
forall (m :: * -> *) a.
Monad m =>
Parser a -> ParseChunks m Bytes ParseError a
P.parseChunks (Parser Value
value Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) m Bytes
mi Bytes
inp

--------------------------------------------------------------------------------

-- | The only valid whitespace in a JSON document is space, newline,
-- carriage pure, and tab.
skipSpaces :: P.Parser ()
{-# INLINE skipSpaces #-}
skipSpaces :: Parser ()
skipSpaces = (Word8 -> Bool) -> Parser ()
P.skipWhile (\ Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0a Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0d Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x09)

-- | JSON 'Value' parser.
value :: P.Parser Value
{-# INLINABLE value #-}
value :: Parser Value
value = do
    Parser ()
skipSpaces
    Word8
w <- Parser Word8
P.peek
    case Word8
w of
        DOUBLE_QUOTE    -> P.skipWord8 *> (String <$> string_)
        OPEN_CURLY      -> P.skipWord8 *> (Object <$> object_)
        OPEN_SQUARE     -> P.skipWord8 *> (Array <$> array_)
        Word8
C_f             -> Bytes -> Parser ()
P.bytes Bytes
"false" Parser () -> Value -> Parser Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Bool -> Value
Bool Bool
False)
        Word8
C_t             -> Bytes -> Parser ()
P.bytes Bytes
"true" Parser () -> Value -> Parser Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Bool -> Value
Bool Bool
True)
        Word8
C_n             -> Bytes -> Parser ()
P.bytes Bytes
"null" Parser () -> Value -> Parser Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Value
Null
        Word8
_   | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57 Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== MINUS -> Number <$> P.scientific'
            | Bool
otherwise -> Text -> Parser Value
forall a. Text -> Parser a
P.fail' Text
"Z.Data.JSON.Value.value: not a valid json value"

-- | parse json array with leading OPEN_SQUARE.
array :: P.Parser (V.Vector Value)
{-# INLINE array #-}
array :: Parser (Vector Value)
array = Word8 -> Parser ()
P.word8 OPEN_SQUARE *> array_

-- | parse json array without leading OPEN_SQUARE.
array_ :: P.Parser (V.Vector Value)
{-# INLINABLE array_ #-}
array_ :: Parser (Vector Value)
array_ = do
    Parser ()
skipSpaces
    Word8
w <- Parser Word8
P.peek
    if Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== CLOSE_SQUARE
    then Parser ()
P.skipWord8 Parser () -> Vector Value -> Parser (Vector Value)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Vector Value
forall (v :: * -> *) a. Vec v a => v a
V.empty
    else [Value] -> Int -> Parser (Vector Value)
loop [] Int
1
  where
    loop :: [Value] -> Int -> P.Parser (V.Vector Value)
    loop :: [Value] -> Int -> Parser (Vector Value)
loop [Value]
acc !Int
n = do
        !Value
v <- Parser Value
value
        Parser ()
skipSpaces
        let acc' :: [Value]
acc' = Value
vValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
acc
        Word8
ch <- (Word8 -> Bool) -> Parser Word8
P.satisfy ((Word8 -> Bool) -> Parser Word8)
-> (Word8 -> Bool) -> Parser Word8
forall a b. (a -> b) -> a -> b
$ \Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== COMMA || w Word8
== CLOSE_SQUARE
        if Word8
ch Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== COMMA
        then Parser ()
skipSpaces Parser () -> Parser (Vector Value) -> Parser (Vector Value)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Value] -> Int -> Parser (Vector Value)
loop [Value]
acc' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        else Vector Value -> Parser (Vector Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Value -> Parser (Vector Value))
-> Vector Value -> Parser (Vector Value)
forall a b. (a -> b) -> a -> b
$! Int -> [Value] -> Vector Value
forall (v :: * -> *) a. Vec v a => Int -> [a] -> v a
V.packRN Int
n [Value]
acc'  -- n start from 1, so no need to +1 here

-- | parse json array with leading OPEN_CURLY.
object :: P.Parser (V.Vector (T.Text, Value))
{-# INLINE object #-}
object :: Parser (Vector (Text, Value))
object = Word8 -> Parser ()
P.word8 OPEN_CURLY *> object_

-- | parse json object without leading OPEN_CURLY.
object_ :: P.Parser (V.Vector (T.Text, Value))
{-# INLINABLE object_ #-}
object_ :: Parser (Vector (Text, Value))
object_ = do
    Parser ()
skipSpaces
    Word8
w <- Parser Word8
P.peek
    if Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== CLOSE_CURLY
    then Parser ()
P.skipWord8 Parser () -> Vector (Text, Value) -> Parser (Vector (Text, Value))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Vector (Text, Value)
forall (v :: * -> *) a. Vec v a => v a
V.empty
    else [(Text, Value)] -> Int -> Parser (Vector (Text, Value))
loop [] Int
1
 where
    loop :: [(T.Text, Value)] -> Int -> P.Parser (V.Vector (T.Text, Value))
    loop :: [(Text, Value)] -> Int -> Parser (Vector (Text, Value))
loop [(Text, Value)]
acc !Int
n = do
        !Text
k <- Parser Text
string
        Parser ()
skipSpaces
        Word8 -> Parser ()
P.word8 COLON
        !Value
v <- Parser Value
value
        Parser ()
skipSpaces
        let acc' :: [(Text, Value)]
acc' = (Text
k, Value
v) (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
: [(Text, Value)]
acc
        Word8
ch <- (Word8 -> Bool) -> Parser Word8
P.satisfy ((Word8 -> Bool) -> Parser Word8)
-> (Word8 -> Bool) -> Parser Word8
forall a b. (a -> b) -> a -> b
$ \Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== COMMA || w == CLOSE_CURLY
        if Word8
ch Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== COMMA
        then Parser ()
skipSpaces Parser ()
-> Parser (Vector (Text, Value)) -> Parser (Vector (Text, Value))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [(Text, Value)] -> Int -> Parser (Vector (Text, Value))
loop [(Text, Value)]
acc' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        else Vector (Text, Value) -> Parser (Vector (Text, Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector (Text, Value) -> Parser (Vector (Text, Value)))
-> Vector (Text, Value) -> Parser (Vector (Text, Value))
forall a b. (a -> b) -> a -> b
$! Int -> [(Text, Value)] -> Vector (Text, Value)
forall (v :: * -> *) a. Vec v a => Int -> [a] -> v a
V.packRN Int
n [(Text, Value)]
acc'  -- n start from 1, so no need to +1 here

--------------------------------------------------------------------------------

string :: P.Parser T.Text
{-# INLINE string #-}
string :: Parser Text
string = Word8 -> Parser ()
P.word8 DOUBLE_QUOTE *> string_

string_ :: P.Parser T.Text
{-# INLINE string_ #-}
string_ :: Parser Text
string_ = do
    (Bytes
bs, Word32
state) <- Word32
-> (Word32 -> Bytes -> Either Word32 (Bytes, Bytes, Word32))
-> Parser (Bytes, Word32)
forall s.
s
-> (s -> Bytes -> Either s (Bytes, Bytes, s)) -> Parser (Bytes, s)
P.scanChunks Word32
0 Word32 -> Bytes -> Either Word32 (Bytes, Bytes, Word32)
go
    let mt :: Maybe Text
mt = case Word32
state Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF of
            -- need escaping
            Word32
1 -> IO (Maybe Text) -> Maybe Text
forall a. IO a -> a
unsafeDupablePerformIO (do
                    let !len :: Int
len = Bytes -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
bs
                    (!PrimArray Word8
pa, !Int
len') <- Int -> (MBA# Word8 -> IO Int) -> IO (PrimArray Word8, Int)
forall a b.
Prim a =>
Int -> (MBA# Word8 -> IO b) -> IO (PrimArray a, b)
allocPrimArrayUnsafe Int
len (\ MBA# Word8
mba# ->
                        Bytes -> (BA# Word8 -> Int -> Int -> IO Int) -> IO Int
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
bs (MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int
decode_json_string MBA# Word8
mba#))
                    if Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
                    then Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just (Bytes -> Text
T.Text (PrimArray Word8 -> Int -> Int -> Bytes
forall a. PrimArray a -> Int -> Int -> PrimVector a
V.PrimVector PrimArray Word8
pa Int
0 Int
len')))  -- unescaping also validate utf8
                    else Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing)
            Word32
3 -> Maybe Text
forall a. Maybe a
Nothing    -- reject unescaped control characters
            Word32
_ -> Bytes -> Maybe Text
T.validateMaybe Bytes
bs
    case Maybe Text
mt of
        Just Text
t -> Parser ()
P.skipWord8 Parser () -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
t
        Maybe Text
_  -> Text -> Parser Text
forall a. Text -> Parser a
P.fail' Text
"Z.Data.JSON.Value.string_: utf8 validation or unescaping failed"
  where
    go :: Word32 -> V.Bytes -> Either Word32 (V.Bytes, V.Bytes, Word32)
    go :: Word32 -> Bytes -> Either Word32 (Bytes, Bytes, Word32)
go !Word32
state Bytes
v =
        case IO (Word32, Int) -> (Word32, Int)
forall a. IO a -> a
unsafeDupablePerformIO (IO (Word32, Int) -> (Word32, Int))
-> ((MBA# Word8 -> IO Int) -> IO (Word32, Int))
-> (MBA# Word8 -> IO Int)
-> (Word32, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> (MBA# Word8 -> IO Int) -> IO (Word32, Int)
forall a b. Prim a => a -> (MBA# Word8 -> IO b) -> IO (a, b)
withPrimUnsafe Word32
state ((MBA# Word8 -> IO Int) -> (Word32, Int))
-> (MBA# Word8 -> IO Int) -> (Word32, Int)
forall a b. (a -> b) -> a -> b
$ \ MBA# Word8
ps ->
                Bytes -> (BA# Word8 -> Int -> Int -> IO Int) -> IO Int
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
v (MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int
find_json_string_end MBA# Word8
ps)
        of (Word32
state', Int
len)
            | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 ->
                let !r :: Bytes
r = Int -> Bytes -> Bytes
forall (v :: * -> *) a. Vec v a => Int -> v a -> v a
V.unsafeTake Int
len Bytes
v
                    !rest :: Bytes
rest = Int -> Bytes -> Bytes
forall (v :: * -> *) a. Vec v a => Int -> v a -> v a
V.unsafeDrop Int
len Bytes
v
                in (Bytes, Bytes, Word32) -> Either Word32 (Bytes, Bytes, Word32)
forall a b. b -> Either a b
Right (Bytes
r, Bytes
rest, Word32
state')
            | Bool
otherwise -> Word32 -> Either Word32 (Bytes, Bytes, Word32)
forall a b. a -> Either a b
Left Word32
state'

foreign import ccall unsafe find_json_string_end :: MBA# Word32 -> BA# Word8 -> Int -> Int -> IO Int
foreign import ccall unsafe decode_json_string :: MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int