{-|
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''.
  * 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(..), key, nth
    -- * parse into JSON Value
  , parseValue
  , parseValue'
    -- * Value Parsers
  , value
  , object
  , array
  , string
  , skipSpaces
    -- * Convert to Scientific
  , floatToScientific
  , doubleToScientific
  ) where

import           Control.DeepSeq
import           Data.Bits                  ((.&.))
import           Data.Functor
import           Data.Scientific            (Scientific, scientific)
import           Data.Typeable
import           Data.Int
import           Data.Word
import           GHC.Generics
import           Z.Data.ASCII
import qualified Z.Data.Parser              as P
import qualified Z.Data.Builder.Numeric     as B
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.Data.Vector.Search       as V
import           Z.Foreign
import           System.IO.Unsafe           (unsafeDupablePerformIO)
import           Test.QuickCheck.Arbitrary  (Arbitrary(..))
import           Test.QuickCheck.Gen        (Gen(..), listOf)

--------------------------------------------------------------------------------
-- | 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
_          = []

-- | Lense for 'Array' element.
--
-- 1. return `Null` if 'Value' is not an 'Array' or index not exist.
-- 2. Modify will have no effect if 'Value' is not an 'Array' or index not exist.
--
nth :: Functor f => Int -> (Value -> f Value) -> Value -> f Value
{-# INLINABLE nth #-}
nth :: Int -> (Value -> f Value) -> Value -> f Value
nth Int
ix Value -> f Value
f (Array Vector Value
vs) | Just Value
v <- Vector Value
vs Vector Value -> Int -> Maybe Value
forall (v :: * -> *) a. Vec v a => v a -> Int -> Maybe a
`indexMaybe` Int
ix =
    (Value -> Value) -> f Value -> f Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ Value
x -> Vector Value -> Value
Array (Vector Value -> Int -> (Value -> Value) -> Vector Value
forall (v :: * -> *) a.
(Vec v a, HasCallStack) =>
v a -> Int -> (a -> a) -> v a
V.unsafeModifyIndex Vector Value
vs Int
ix (Value -> Value -> Value
forall a b. a -> b -> a
const Value
x))) (Value -> f Value
f Value
v)
nth Int
_ Value -> f Value
f Value
v = (Value -> Value) -> f Value -> f Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Value -> Value
forall a b. a -> b -> a
const Value
v) (Value -> f Value
f Value
Null)

-- | Lense for 'Object' element
--
-- 1. return `Null` if 'Value' is not an 'Object' or key not exist.
-- 2. Modify will have no effect if 'Value' is not an 'Object' or key not exist.
-- 4. On duplicated keys prefer the last one.
--
key :: Functor f => T.Text -> (Value -> f Value) -> Value -> f Value
{-# INLINABLE key #-}
key :: Text -> (Value -> f Value) -> Value -> f Value
key Text
k Value -> f Value
f (Object Vector (Text, Value)
kvs) | (Int
i, Just (Text
_, Value
v)) <- ((Text, Value) -> Bool)
-> Vector (Text, Value) -> (Int, Maybe (Text, Value))
forall (v :: * -> *) a.
Vec v a =>
(a -> Bool) -> v a -> (Int, Maybe a)
V.findR ((Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) (Text -> Bool) -> ((Text, Value) -> Text) -> (Text, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value) -> Text
forall a b. (a, b) -> a
fst) Vector (Text, Value)
kvs =
    (Value -> Value) -> f Value -> f Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ Value
x -> Vector (Text, Value) -> Value
Object (Vector (Text, Value)
-> Int -> ((Text, Value) -> (Text, Value)) -> Vector (Text, Value)
forall (v :: * -> *) a.
(Vec v a, HasCallStack) =>
v a -> Int -> (a -> a) -> v a
V.unsafeModifyIndex Vector (Text, Value)
kvs Int
i ((Text, Value) -> (Text, Value) -> (Text, Value)
forall a b. a -> b -> a
const (Text
k, Value
x)))) (Value -> f Value
f Value
v)
key Text
_ Value -> f Value
f Value
v = (Value -> Value) -> f Value -> f Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Value -> Value
forall a b. a -> b -> a
const Value
v) (Value -> f Value
f Value
Null)

-- | 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)

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

-- | 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
        Word8
DOUBLE_QUOTE    -> Parser ()
P.skipWord8 Parser () -> Parser Value -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Value
String (Text -> Value) -> Parser Text -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_)
        Word8
CURLY_LEFT      -> Parser ()
P.skipWord8 Parser () -> Parser Value -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> Parser (Vector (Text, Value)) -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Vector (Text, Value))
object_)
        Word8
SQUARE_LEFT     -> Parser ()
P.skipWord8 Parser () -> Parser Value -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Vector Value -> Value
Array (Vector Value -> Value) -> Parser (Vector Value) -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Vector Value)
array_)
        Word8
LETTER_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
LETTER_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
LETTER_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
== Word8
MINUS -> Scientific -> Value
Number (Scientific -> Value) -> Parser Scientific -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Scientific
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 SQUARE_LEFT.
array :: P.Parser (V.Vector Value)
{-# INLINE array #-}
array :: Parser (Vector Value)
array = Word8 -> Parser ()
P.word8 Word8
SQUARE_LEFT Parser () -> Parser (Vector Value) -> Parser (Vector Value)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Vector Value)
array_

-- | parse json array without leading SQUARE_LEFT.
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
== Word8
SQUARE_RIGHT
    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
== Word8
COMMA Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
SQUARE_RIGHT
        if Word8
ch Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
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 'CURLY_LEFT'.
object :: P.Parser (V.Vector (T.Text, Value))
{-# INLINE object #-}
object :: Parser (Vector (Text, Value))
object = Word8 -> Parser ()
P.word8 Word8
CURLY_LEFT Parser ()
-> Parser (Vector (Text, Value)) -> Parser (Vector (Text, Value))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Vector (Text, Value))
object_

-- | parse json object without leading 'CURLY_LEFT'.
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
== Word8
CURLY_RIGHT
    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 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
== Word8
COMMA Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
CURLY_RIGHT
        if Word8
ch Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
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 Word8
DOUBLE_QUOTE Parser () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
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

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

-- | Convert IEEE float to scientific notition.
floatToScientific :: Float -> Scientific
{-# INLINE floatToScientific #-}
floatToScientific :: Float -> Scientific
floatToScientific Float
rf | Float
rf Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0    = -(([Int], Int) -> Scientific
fromFloatingDigits (Float -> ([Int], Int)
B.grisu3_sp (-Float
rf)))
                     | Float
rf Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0   = Scientific
0
                     | Bool
otherwise = ([Int], Int) -> Scientific
fromFloatingDigits (Float -> ([Int], Int)
B.grisu3_sp Float
rf)

-- | Convert IEEE double to scientific notition.
doubleToScientific :: Double -> Scientific
{-# INLINE doubleToScientific #-}
doubleToScientific :: Double -> Scientific
doubleToScientific Double
rf | Double
rf Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0    = -(([Int], Int) -> Scientific
fromFloatingDigits (Double -> ([Int], Int)
B.grisu3 (-Double
rf)))
                      | Double
rf Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0   = Scientific
0
                      | Bool
otherwise = ([Int], Int) -> Scientific
fromFloatingDigits (Double -> ([Int], Int)
B.grisu3 Double
rf)

fromFloatingDigits :: ([Int], Int) -> Scientific
{-# INLINE fromFloatingDigits #-}
fromFloatingDigits :: ([Int], Int) -> Scientific
fromFloatingDigits ([Int]
digits, Int
e) = [Int] -> Int64 -> Int -> Scientific
go [Int]
digits Int64
0 Int
0
  where
    -- There's no way a float or double has more digits a 'Int64' can't handle
    go :: [Int] -> Int64 -> Int -> Scientific
    go :: [Int] -> Int64 -> Int -> Scientific
go []     !Int64
c !Int
n = Integer -> Int -> Scientific
scientific (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
c) (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
    go (Int
d:[Int]
ds) !Int64
c !Int
n = [Int] -> Int64 -> Int -> Scientific
go [Int]
ds (Int64
c Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)