{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE MagicHash          #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE UnliftedFFITypes   #-}
{-# LANGUAGE TypeApplications   #-}

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

This module provides builders for JSON 'Value's, a Haskell JSON representation. These builders are designed to comply with <https://tools.ietf.org/html/rfc8258 rfc8258>. Only control characters are escaped, other unicode codepoints are directly written instead of being escaped.

-}
module Z.Data.JSON.Builder
  ( -- * Value Builders
    value
  , object
  , object'
  , array
  , array'
  , string
    -- * Builder helpers
  , kv, kv'
    -- * Re-export 'Value' type
  , Value(..)
  ) where

import           Control.Monad
import           Control.Monad.ST.Unsafe  (unsafeIOToST)
import           Data.Primitive.PrimArray
import           Data.Word
import           GHC.Prim                 (unsafeCoerce#)
import qualified Z.Data.Builder              as B
import qualified Z.Data.Builder.Base         as B
import qualified Z.Data.Text            as T
import qualified Z.Data.Text.Base       as T
import           Z.Data.Vector.Base     as V
import           Z.Foreign
import           Z.Data.JSON.Value      (Value(..))

#define DOUBLE_QUOTE 34

-- | Use @:@ as separator to connect a label(no need to escape, only add quotes) with field builders.
kv :: T.Text -> B.Builder () -> B.Builder ()
{-# INLINE kv #-}
Text
l kv :: Text -> Builder () -> Builder ()
`kv` Builder ()
b = Builder () -> Builder ()
B.quotes (Text -> Builder ()
B.text Text
l) Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
B.colon Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
b

-- | Use @:@ as separator to connect a label(escaped and add quotes) with field builders.
kv' :: T.Text -> B.Builder () -> B.Builder ()
{-# INLINE kv' #-}
Text
l kv' :: Text -> Builder () -> Builder ()
`kv'` Builder ()
b = Text -> Builder ()
string Text
l Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
B.colon Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
b

-- | Encode a 'Value', you can use this function with 'toValue' to get 'encodeJSON' with a small overhead.
value :: Value -> B.Builder ()
{-# INLINABLE value #-}
value :: Value -> Builder ()
value (Object Vector (Text, Value)
kvs) = Vector (Text, Value) -> Builder ()
object Vector (Text, Value)
kvs
value (Array Vector Value
vs) = Vector Value -> Builder ()
array Vector Value
vs
value (String Text
t) = Text -> Builder ()
string Text
t
value (Number Scientific
n) = Scientific -> Builder ()
B.scientific Scientific
n
value (Bool Bool
True) = Builder ()
"true"
value (Bool Bool
False) = Builder ()
"false"
value Value
Null = Builder ()
"null"

array :: V.Vector Value -> B.Builder ()
{-# INLINE array #-}
array :: Vector Value -> Builder ()
array = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (Vector Value -> Builder ()) -> Vector Value -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> (Value -> Builder ()) -> Vector Value -> Builder ()
forall (v :: * -> *) a.
Vec v a =>
Builder () -> (a -> Builder ()) -> v a -> Builder ()
B.intercalateVec Builder ()
B.comma Value -> Builder ()
value

array' :: (a -> B.Builder ()) -> V.Vector a -> B.Builder ()
{-# INLINE array' #-}
array' :: (a -> Builder ()) -> Vector a -> Builder ()
array' a -> Builder ()
f = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (Vector a -> Builder ()) -> Vector a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> (a -> Builder ()) -> Vector a -> Builder ()
forall (v :: * -> *) a.
Vec v a =>
Builder () -> (a -> Builder ()) -> v a -> Builder ()
B.intercalateVec Builder ()
B.comma a -> Builder ()
f

object :: V.Vector (T.Text, Value) -> B.Builder ()
{-# INLINE object #-}
object :: Vector (Text, Value) -> Builder ()
object = Builder () -> Builder ()
B.curly (Builder () -> Builder ())
-> (Vector (Text, Value) -> Builder ())
-> Vector (Text, Value)
-> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder ()
-> ((Text, Value) -> Builder ())
-> Vector (Text, Value)
-> Builder ()
forall (v :: * -> *) a.
Vec v a =>
Builder () -> (a -> Builder ()) -> v a -> Builder ()
B.intercalateVec Builder ()
B.comma (\ (Text
k, Value
v) -> Text
k Text -> Builder () -> Builder ()
`kv'` Value -> Builder ()
value Value
v)

object' :: (a -> B.Builder ()) -> V.Vector (T.Text, a) -> B.Builder ()
{-# INLINE object' #-}
object' :: (a -> Builder ()) -> Vector (Text, a) -> Builder ()
object' a -> Builder ()
f = Builder () -> Builder ()
B.curly (Builder () -> Builder ())
-> (Vector (Text, a) -> Builder ())
-> Vector (Text, a)
-> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder ()
-> ((Text, a) -> Builder ()) -> Vector (Text, a) -> Builder ()
forall (v :: * -> *) a.
Vec v a =>
Builder () -> (a -> Builder ()) -> v a -> Builder ()
B.intercalateVec Builder ()
B.comma (\ (Text
k, a
v) -> Text
k Text -> Builder () -> Builder ()
`kv'` a -> Builder ()
f a
v)

-- | Escape text into JSON string and add double quotes, escaping rules:
--
-- @
--    \'\\b\':  \"\\b\"
--    \'\\f\':  \"\\f\"
--    \'\\n\':  \"\\n\"
--    \'\\r\':  \"\\r\"
--    \'\\t\':  \"\\t\"
--    \'\"\':  \"\\\"\"
--    \'\\\':  \"\\\\\"
--    \'\/\':  \"\\/\"
--    other chars <= 0x1F: "\\u00XX"
-- @
--
string :: T.Text -> B.Builder ()
{-# INLINE string #-}
string :: Text -> Builder ()
string (T.Text (V.PrimVector ba :: PrimArray Word8
ba@(PrimArray ByteArray#
ba#) Int
s Int
l)) = do
    let siz :: Int
siz = ByteArray# -> Int -> Int -> Int
escape_json_string_length ByteArray#
ba# Int
s Int
l
    Int -> Builder ()
B.ensureN Int
siz
    (forall s.
 AllocateStrategy s -> (() -> BuildStep s) -> BuildStep s)
-> Builder ()
forall a.
(forall s. AllocateStrategy s -> (a -> BuildStep s) -> BuildStep s)
-> Builder a
B.Builder (\ AllocateStrategy s
_  () -> BuildStep s
k (B.Buffer mba :: MutablePrimArray s Word8
mba@(MutablePrimArray MutableByteArray# s
mba#) Int
i) -> do
        if Int
siz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2   -- no need to escape
        then do
            MutablePrimArray (PrimState (ST s)) Word8
-> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Word8
MutablePrimArray (PrimState (ST s)) Word8
mba Int
i DOUBLE_QUOTE
            MutablePrimArray (PrimState (ST s)) Word8
-> Int -> PrimArray Word8 -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray s Word8
MutablePrimArray (PrimState (ST s)) Word8
mba (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) PrimArray Word8
ba Int
s Int
l
            MutablePrimArray (PrimState (ST s)) Word8
-> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Word8
MutablePrimArray (PrimState (ST s)) Word8
mba (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
l) DOUBLE_QUOTE
        else ST s Int -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s Int -> ST s ()) -> ST s Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ IO Int -> ST s Int
forall a s. IO a -> ST s a
unsafeIOToST (ByteArray# -> Int -> Int -> MBA# Word8 -> Int -> IO Int
escape_json_string ByteArray#
ba# Int
s Int
l (MutableByteArray# s -> MBA# Word8
unsafeCoerce# MutableByteArray# s
mba#) Int
i)
        () -> BuildStep s
k () (MutablePrimArray s Word8 -> Int -> Buffer s
forall s. MutablePrimArray s Word8 -> Int -> Buffer s
B.Buffer MutablePrimArray s Word8
mba (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
siz)))

foreign import ccall unsafe escape_json_string_length
    :: BA# Word8 -> Int -> Int -> Int

foreign import ccall unsafe escape_json_string
    :: BA# Word8 -> Int -> Int -> MBA# Word8 -> Int -> IO Int