{-|
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
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
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
Ord, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
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. 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 ()
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) = forall a. NFData a => a -> ()
rnf Vector (Text, Value)
o
    rnf (Array  Vector Value
a) = forall a. NFData a => a -> ()
rnf Vector Value
a
    rnf (String Text
s) = forall a. NFData a => a -> ()
rnf Text
s
    rnf (Number Scientific
n) = forall a. NFData a => a -> ()
rnf Scientific
n
    rnf (Bool   Bool
b) = 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 <- forall a. Arbitrary a => Gen a
arbitrary :: Gen Word
            case (Word
i forall a. Integral a => a -> a -> a
`mod` Word
6) of
                Word
0 -> if Int
d forall a. Ord a => a -> a -> Bool
< Int
s then Vector (Text, Value) -> Value
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf (forall {a}. Arbitrary a => Int -> Int -> Gen (a, Value)
arbitraryKV (Int
dforall a. Num a => a -> a -> a
+Int
1) Int
s)
                              else forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
                Word
1 -> if Int
d forall a. Ord a => a -> a -> Bool
< Int
s then Vector Value -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf (Int -> Int -> Gen Value
arbitraryValue (Int
dforall a. Num a => a -> a -> a
+Int
1) Int
s)
                              else forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
                Word
2 -> Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
                Word
3 -> do
                    Integer
c <- forall a. Arbitrary a => Gen a
arbitrary
                    Int
e <- forall a. Arbitrary a => Gen a
arbitrary
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
Number forall a b. (a -> b) -> a -> b
$! Integer -> Int -> Scientific
scientific Integer
c Int
e
                Word
4 -> Bool -> Value
Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
                Word
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null

        arbitraryKV :: Int -> Int -> Gen (a, Value)
arbitraryKV Int
d Int
s = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary 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) = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Text, Value)
kvs)
    shrink (Array Vector Value
vs) = 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 :: forall (f :: * -> *).
Functor f =>
Int -> (Value -> f Value) -> Value -> f Value
nth Int
ix Value -> f Value
f (Array Vector Value
vs) | Just Value
v <- Vector Value
vs forall (v :: * -> *) a. Vec v a => v a -> Int -> Maybe a
`indexMaybe` Int
ix =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ Value
x -> Vector Value -> Value
Array (forall (v :: * -> *) a.
(Vec v a, HasCallStack) =>
v a -> Int -> (a -> a) -> v a
V.unsafeModifyIndex Vector Value
vs Int
ix (forall a b. a -> b -> a
const Value
x))) (Value -> f Value
f Value
v)
nth Int
_ Value -> f Value
f Value
v = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 :: forall (f :: * -> *).
Functor f =>
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)) <- forall (v :: * -> *) a.
Vec v a =>
(a -> Bool) -> v a -> (Int, Maybe a)
V.findR ((Text
k forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Vector (Text, Value)
kvs =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ Value
x -> Vector (Text, Value) -> Value
Object (forall (v :: * -> *) a.
(Vec v a, HasCallStack) =>
v a -> Int -> (a -> a) -> v a
V.unsafeModifyIndex Vector (Text, Value)
kvs Int
i (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = 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' = forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser Value
value forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces 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 forall a. Ord a => a -> a -> Bool
<= Word8
0x20 Bool -> Bool -> Bool
&& (Word8
w forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
0x0a Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
0x0d Bool -> Bool -> Bool
|| Word8
w 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_)
        Word8
CURLY_LEFT      -> Parser ()
P.skipWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Vector (Text, Value) -> Value
Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Vector (Text, Value))
object_)
        Word8
SQUARE_LEFT     -> Parser ()
P.skipWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Vector Value -> Value
Array 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" 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" 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" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Value
Null
        Word8
_   | Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
<= Word8
57 Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
MINUS -> Scientific -> Value
Number forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Scientific
P.scientific'
            | Bool
otherwise -> 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)
{-# INLINABLE array #-}
array :: Parser (Vector Value)
array = Word8 -> Parser ()
P.word8 Word8
SQUARE_LEFT 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)
{-# INLINE array_ #-}
array_ :: Parser (Vector Value)
array_ = do
    Parser ()
skipSpaces
    Word8
w <- Parser Word8
P.peek
    if Word8
w forall a. Eq a => a -> a -> Bool
== Word8
SQUARE_RIGHT
    then Parser ()
P.skipWord8 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 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
vforall a. a -> [a] -> [a]
:[Value]
acc
        Word8
ch <- (Word8 -> Bool) -> Parser Word8
P.satisfy forall a b. (a -> b) -> a -> b
$ \Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Word8
COMMA Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
SQUARE_RIGHT
        if Word8
ch forall a. Eq a => a -> a -> Bool
== Word8
COMMA
        then Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Value] -> Int -> Parser (Vector Value)
loop [Value]
acc' (Int
nforall a. Num a => a -> a -> a
+Int
1)
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! 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))
{-# INLINABLE object #-}
object :: Parser (Vector (Text, Value))
object = Word8 -> Parser ()
P.word8 Word8
CURLY_LEFT 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))
{-# INLINE object_ #-}
object_ :: Parser (Vector (Text, Value))
object_ = do
    Parser ()
skipSpaces
    Word8
w <- Parser Word8
P.peek
    if Word8
w forall a. Eq a => a -> a -> Bool
== Word8
CURLY_RIGHT
    then Parser ()
P.skipWord8 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 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) forall a. a -> [a] -> [a]
: [(Text, Value)]
acc
        Word8
ch <- (Word8 -> Bool) -> Parser Word8
P.satisfy forall a b. (a -> b) -> a -> b
$ \Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Word8
COMMA Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
CURLY_RIGHT
        if Word8
ch forall a. Eq a => a -> a -> Bool
== Word8
COMMA
        then Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [(Text, Value)] -> Int -> Parser (Vector (Text, Value))
loop [(Text, Value)]
acc' (Int
nforall a. Num a => a -> a -> a
+Int
1)
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! 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
{-# INLINABLE string #-}
string :: Parser Text
string = Word8 -> Parser ()
P.word8 Word8
DOUBLE_QUOTE 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) <- 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 forall a. Bits a => a -> a -> a
.&. Word32
0xFF of
            -- need escaping
            Word32
1 -> forall a. IO a -> a
unsafeDupablePerformIO (do
                    let !len :: Int
len = forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
bs
                    (!PrimArray Word8
pa, !Int
len') <- forall a b.
Prim a =>
Int -> (MBA# a -> IO b) -> IO (PrimArray a, b)
allocPrimArrayUnsafe Int
len (\ MBA# a
mba# ->
                        forall a b.
Prim a =>
PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
bs (MBA# a -> BA# a -> Int -> Int -> IO Int
decode_json_string MBA# a
mba#))
                    if Int
len' forall a. Ord a => a -> a -> Bool
>= Int
0
                    then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Bytes -> Text
T.Text (forall a. PrimArray a -> Int -> Int -> PrimVector a
V.PrimVector PrimArray Word8
pa Int
0 Int
len')))  -- unescaping also validate utf8
                    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
            Word32
3 -> 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 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
t
        Maybe 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 forall a. IO a -> a
unsafeDupablePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prim a => a -> (MBA# a -> IO b) -> IO (a, b)
withPrimUnsafe Word32
state forall a b. (a -> b) -> a -> b
$ \ MBA# a
ps ->
                forall a b.
Prim a =>
PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
v (MBA# a -> BA# a -> Int -> Int -> IO Int
find_json_string_end MBA# a
ps)
        of (Word32
state', Int
len)
            | Int
len forall a. Ord a => a -> a -> Bool
>= Int
0 ->
                let !r :: Bytes
r = forall (v :: * -> *) a. Vec v a => Int -> v a -> v a
V.unsafeTake Int
len Bytes
v
                    !rest :: Bytes
rest = forall (v :: * -> *) a. Vec v a => Int -> v a -> v a
V.unsafeDrop Int
len Bytes
v
                in forall a b. b -> Either a b
Right (Bytes
r, Bytes
rest, Word32
state')
            | Bool
otherwise -> 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
{-# INLINABLE floatToScientific #-}
floatToScientific :: Float -> Scientific
floatToScientific Float
rf | Float
rf forall a. Ord a => a -> a -> Bool
< Float
0    = -(([Int], Int) -> Scientific
fromFloatingDigits (Float -> ([Int], Int)
B.grisu3_sp (-Float
rf)))
                     | Float
rf 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
{-# INLINABLE doubleToScientific #-}
doubleToScientific :: Double -> Scientific
doubleToScientific Double
rf | Double
rf forall a. Ord a => a -> a -> Bool
< Double
0    = -(([Int], Int) -> Scientific
fromFloatingDigits (Double -> ([Int], Int)
B.grisu3 (-Double
rf)))
                      | Double
rf 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
{-# INLINABLE 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
c) (Int
e 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 forall a. Num a => a -> a -> a
* Int64
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d) (Int
n forall a. Num a => a -> a -> a
+ Int
1)