{-|
Module      : Z.Data.JSON.Base
Description : Fast JSON serialization/deserialization
Copyright   : (c) Dong Han, 2019
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides 'Converter' to convert 'Value' to haskell data types, and various tools to help
user define 'JSON' instance.

-}

module Z.Data.JSON.Base
  ( -- * JSON Class
    JSON(..), Value(..), defaultSettings, Settings(..)
  , -- * Encode & Decode
    DecodeError
  , decode, decode', decodeText, decodeText', P.ParseChunks, decodeChunks
  , encode, encodeChunks, encodeText
    -- * parse into JSON Value
  , JV.parseValue, JV.parseValue', JV.parseValueChunks, JV.parseValueChunks'
  -- * Generic functions
  , gToValue, gFromValue, gEncodeJSON
  -- * Convert 'Value' to Haskell data
  , convertValue, Converter(..), fail', (<?>), prependContext
  , PathElement(..), ConvertError(..)
  , typeMismatch, fromNull, withBool, withScientific, withBoundedScientific, withRealFloat
  , withBoundedIntegral, withText, withArray, withKeyValues, withFlatMap, withFlatMapR
  , withHashMap, withHashMapR, withEmbeddedJSON
  , (.:), (.:?), (.:!), convertField, convertFieldMaybe, convertFieldMaybe'
  -- * Helper for manually writing instance.
  , (.=), object, (.!), object', KVItem
  , JB.kv, JB.kv'
  , JB.string
  , B.curly, B.square
  , commaSepList
  , commaSepVec
  ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.ST
import           Data.Char                      (ord)
import           Data.Data
import           Data.Fixed
import           Data.Functor.Compose
import           Data.Functor.Const
import           Data.Functor.Identity
import           Data.Functor.Product
import           Data.Functor.Sum
import           Data.Hashable
import qualified Data.Foldable                  as Foldable
import qualified Data.HashMap.Strict            as HM
import qualified Data.HashSet                   as HS
import qualified Data.IntMap                    as IM
import qualified Data.IntSet                    as IS
import qualified Data.Map.Strict                as M
import qualified Data.Sequence                  as Seq
import qualified Data.Set                       as Set
import qualified Data.Tree                      as Tree
import           Data.Int
import           Data.List.NonEmpty             (NonEmpty (..))
import qualified Data.List.NonEmpty             as NonEmpty
import qualified Data.Monoid                    as Monoid
import qualified Data.Primitive.ByteArray       as A
import qualified Data.Primitive.SmallArray      as A
import           Data.Primitive.Types           (Prim)
import           Data.Proxy                     (Proxy (..))
import           Data.Ratio                     (Ratio, denominator, numerator, (%))
import           Data.Scientific                (Scientific, base10Exponent, toBoundedInteger)
import qualified Data.Scientific                as Scientific
import qualified Data.Semigroup                 as Semigroup
import           Data.Tagged                    (Tagged (..))
import           Data.Time                      (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
import           Data.Time.Calendar             (CalendarDiffDays (..), DayOfWeek (..))
import           Data.Time.LocalTime            (CalendarDiffTime (..))
import           Data.Time.Clock.System         (SystemTime (..))
import           Data.Version                   (Version(versionBranch), makeVersion)
import           Data.Word
import           Foreign.C.Types
import           GHC.Exts                       (Proxy#, proxy#)
import           GHC.Generics
import           GHC.Natural
import           System.Exit
import qualified Z.Data.Array                   as A
import qualified Z.Data.Builder                 as B
import           Z.Data.Generics.Utils
import qualified Z.Data.JSON.Builder            as JB
import           Z.Data.JSON.Converter
import           Z.Data.JSON.Value              (Value (..))
import qualified Z.Data.JSON.Value              as JV
import qualified Z.Data.Parser                  as P
import qualified Z.Data.Parser.Numeric          as P
import qualified Z.Data.Text.Base               as T
import qualified Z.Data.Text                    as T
import qualified Z.Data.Text.Print              as T
import qualified Z.Data.Vector.Base             as V
import qualified Z.Data.Vector.Extra            as V
import qualified Z.Data.Vector.FlatIntMap       as FIM
import qualified Z.Data.Vector.FlatIntSet       as FIS
import qualified Z.Data.Vector.FlatMap          as FM
import qualified Z.Data.Vector.FlatSet          as FS

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

-- | Type class for encode & decode JSON.
class JSON a where
    fromValue :: Value -> Converter a
    default fromValue :: (Generic a, GFromValue (Rep a)) => Value -> Converter a
    fromValue Value
v = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Converter (Rep a Any) -> Converter a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (Rep a Any)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
defaultSettings Value
v
    {-# INLINABLE fromValue #-}

    toValue :: a -> Value
    default toValue :: (Generic a, GToValue (Rep a)) => a -> Value
    toValue = Settings -> Rep a Any -> Value
forall k (f :: k -> *) (a :: k).
GToValue f =>
Settings -> f a -> Value
gToValue Settings
defaultSettings (Rep a Any -> Value) -> (a -> Rep a Any) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from
    {-# INLINABLE toValue #-}

    encodeJSON :: a -> B.Builder ()
    default encodeJSON :: (Generic a, GEncodeJSON (Rep a)) => a -> B.Builder ()
    encodeJSON = Settings -> Rep a Any -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
defaultSettings (Rep a Any -> Builder ()) -> (a -> Rep a Any) -> a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from
    {-# INLINABLE encodeJSON #-}

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

-- There're two possible failures here:
--
--   * 'P.ParseError' is an error during parsing bytes to 'Value'.
--   * 'ConvertError' is an error when converting 'Value' to target data type.
type DecodeError = Either P.ParseError ConvertError

-- | Decode a JSON doc, only trailing JSON whitespace are allowed.
decodeText' :: JSON a => T.Text -> Either DecodeError a
{-# INLINE decodeText' #-}
decodeText' :: Text -> Either DecodeError a
decodeText' = Bytes -> Either DecodeError a
forall a. JSON a => Bytes -> Either DecodeError a
decode' (Bytes -> Either DecodeError a)
-> (Text -> Bytes) -> Text -> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bytes
T.getUTF8Bytes

-- | Decode a JSON text, return any trailing text.
decodeText :: JSON a => T.Text -> (T.Text, Either DecodeError a)
{-# INLINE decodeText #-}
decodeText :: Text -> (Text, Either DecodeError a)
decodeText Text
t =
    let (Bytes
rest, Either DecodeError a
r) = Bytes -> (Bytes, Either DecodeError a)
forall a. JSON a => Bytes -> (Bytes, Either DecodeError a)
decode (Text -> Bytes
T.getUTF8Bytes Text
t)
    in (Bytes -> Text
T.Text Bytes
rest, Either DecodeError a
r) -- JSON parser consume bytes in unit of UTF8 codepoint

-- | Decode a JSON doc, only trailing JSON whitespace are allowed.
decode' :: JSON a => V.Bytes -> Either DecodeError a
{-# INLINE decode' #-}
decode' :: Bytes -> Either DecodeError a
decode' Bytes
bs = case Parser Value -> Bytes -> Either ParseError Value
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser Value
JV.value Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
JV.skipSpaces Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) Bytes
bs of
    Left ParseError
pErr -> DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ParseError -> DecodeError
forall a b. a -> Either a b
Left ParseError
pErr)
    Right Value
v -> case Value -> Either ConvertError a
forall a. JSON a => Value -> Either ConvertError a
convertValue Value
v of
        Left ConvertError
cErr -> DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ConvertError -> DecodeError
forall a b. b -> Either a b
Right ConvertError
cErr)
        Right a
r   -> a -> Either DecodeError a
forall a b. b -> Either a b
Right a
r

-- | Decode a JSON bytes, return any trailing bytes.
decode :: JSON a => V.Bytes -> (V.Bytes, Either DecodeError a)
{-# INLINE decode #-}
decode :: Bytes -> (Bytes, Either DecodeError a)
decode Bytes
bs = case Parser Value -> Bytes -> (Bytes, Either ParseError Value)
forall a. Parser a -> Bytes -> (Bytes, Either ParseError a)
P.parse Parser Value
JV.value Bytes
bs of
    (Bytes
bs', Left ParseError
pErr) -> (Bytes
bs', DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ParseError -> DecodeError
forall a b. a -> Either a b
Left ParseError
pErr))
    (Bytes
bs', Right Value
v) -> case Value -> Either ConvertError a
forall a. JSON a => Value -> Either ConvertError a
convertValue Value
v of
        Left ConvertError
cErr -> (Bytes
bs', DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ConvertError -> DecodeError
forall a b. b -> Either a b
Right ConvertError
cErr))
        Right a
r   -> (Bytes
bs', a -> Either DecodeError a
forall a b. b -> Either a b
Right a
r)

-- | Decode JSON doc chunks, return trailing bytes.
decodeChunks :: (JSON a, Monad m) => P.ParseChunks m V.Bytes DecodeError a
{-# INLINE decodeChunks #-}
decodeChunks :: ParseChunks m Bytes DecodeError a
decodeChunks m Bytes
mb Bytes
bs = do
    (Bytes, Either ParseError Value)
mr <- Parser Value -> ParseChunks m Bytes ParseError Value
forall (m :: * -> *) a.
Monad m =>
Parser a -> ParseChunks m Bytes ParseError a
P.parseChunks Parser Value
JV.value m Bytes
mb Bytes
bs
    case (Bytes, Either ParseError Value)
mr of
        (Bytes
bs', Left ParseError
pErr) -> (Bytes, Either DecodeError a) -> m (Bytes, Either DecodeError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes
bs', DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ParseError -> DecodeError
forall a b. a -> Either a b
Left ParseError
pErr))
        (Bytes
bs', Right Value
v) ->
            case Value -> Either ConvertError a
forall a. JSON a => Value -> Either ConvertError a
convertValue Value
v of
                Left ConvertError
cErr -> (Bytes, Either DecodeError a) -> m (Bytes, Either DecodeError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes
bs', DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ConvertError -> DecodeError
forall a b. b -> Either a b
Right ConvertError
cErr))
                Right a
r   -> (Bytes, Either DecodeError a) -> m (Bytes, Either DecodeError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes
bs', a -> Either DecodeError a
forall a b. b -> Either a b
Right a
r)

-- | Directly encode data to JSON bytes.
encode :: JSON a => a -> V.Bytes
{-# INLINE encode #-}
encode :: a -> Bytes
encode = Builder () -> Bytes
forall a. Builder a -> Bytes
B.build (Builder () -> Bytes) -> (a -> Builder ()) -> a -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON

-- | Encode data to JSON bytes chunks.
encodeChunks :: JSON a => a -> [V.Bytes]
{-# INLINE encodeChunks #-}
encodeChunks :: a -> [Bytes]
encodeChunks = Builder () -> [Bytes]
forall a. Builder a -> [Bytes]
B.buildChunks (Builder () -> [Bytes]) -> (a -> Builder ()) -> a -> [Bytes]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON

-- | Text version 'encode'.
encodeText :: JSON a => a -> T.Text
{-# INLINE encodeText #-}
encodeText :: a -> Text
encodeText = Bytes -> Text
T.Text (Bytes -> Text) -> (a -> Bytes) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bytes
forall a. JSON a => a -> Bytes
encode

-- | Run a 'Converter' with input value.
convertValue :: (JSON a) => Value -> Either ConvertError a
{-# INLINE convertValue #-}
convertValue :: Value -> Either ConvertError a
convertValue = (Value -> Converter a) -> Value -> Either ConvertError a
forall a r. (a -> Converter r) -> a -> Either ConvertError r
convert Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue

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

-- | Produce an error message like @converting XXX failed, expected XXX, encountered XXX@.
typeMismatch :: T.Text     -- ^ The name of the type you are trying to convert.
             -> T.Text     -- ^ The JSON value type you expecting to meet.
             -> Value      -- ^ The actual value encountered.
             -> Converter a
{-# INLINE typeMismatch #-}
typeMismatch :: Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
expected Value
v =
    Text -> Converter a
forall a. Text -> Converter a
fail' (Text -> Converter a) -> Text -> Converter a
forall a b. (a -> b) -> a -> b
$ ParseError -> Text
T.concat [Text
"converting ", Text
name, Text
" failed, expected ", Text
expected, Text
", encountered ", Text
actual]
  where
    actual :: Text
actual = case Value
v of
        Object Vector (Text, Value)
_ -> Text
"Object"
        Array Vector Value
_  -> Text
"Array"
        String Text
_ -> Text
"String"
        Number Scientific
_ -> Text
"Number"
        Bool Bool
_   -> Text
"Boolean"
        Value
_        -> Text
"Null"

fromNull :: T.Text -> a -> Value -> Converter a
{-# INLINE fromNull #-}
fromNull :: Text -> a -> Value -> Converter a
fromNull Text
_ a
a Value
Null = a -> Converter a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
fromNull Text
c a
_ Value
v    = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
c Text
"Null" Value
v

withBool :: T.Text -> (Bool -> Converter a) -> Value ->  Converter a
{-# INLINE withBool #-}
withBool :: Text -> (Bool -> Converter a) -> Value -> Converter a
withBool Text
_    Bool -> Converter a
f (Bool Bool
x) = Bool -> Converter a
f Bool
x
withBool Text
name Bool -> Converter a
_ Value
v        = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Bool" Value
v

-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number
-- when @value@ is a 'Z.Data.JSON.Value.Number' and fails using 'typeMismatch'
-- otherwise.
--
-- /Warning/: If you are converting from a scientific to an unbounded
-- type such as 'Integer' you may want to add a restriction on the
-- size of the exponent (see 'withBoundedScientific') to prevent
-- malicious input from filling up the memory of the target system.
--
-- ==== Error message example
--
-- > withScientific "MyType" f (String "oops")
-- > -- Error: "converting MyType failed, expected Number, but encountered String"
withScientific :: T.Text -> (Scientific -> Converter a) -> Value ->  Converter a
{-# INLINE withScientific #-}
withScientific :: Text -> (Scientific -> Converter a) -> Value -> Converter a
withScientific Text
_    Scientific -> Converter a
f (Number Scientific
x) = Scientific -> Converter a
f Scientific
x
withScientific Text
name Scientific -> Converter a
_ Value
v          = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Number" Value
v

-- | @'withRealFloat' try to convert floating number with following rules:
--
--   * Use @±Infinity@ to represent out of range numbers.
--   * Convert @Null@ as @NaN@
--
withRealFloat :: RealFloat a => T.Text -> (a -> Converter r) -> Value -> Converter r
{-# INLINE withRealFloat #-}
withRealFloat :: Text -> (a -> Converter r) -> Value -> Converter r
withRealFloat Text
_    a -> Converter r
f (Number Scientific
s) = a -> Converter r
f (Scientific -> a
forall a. RealFloat a => Scientific -> a
Scientific.toRealFloat Scientific
s)
withRealFloat Text
_    a -> Converter r
f Value
Null       = a -> Converter r
f (a
0a -> a -> a
forall a. Fractional a => a -> a -> a
/a
0)
withRealFloat Text
name a -> Converter r
_ Value
v          = Text -> Text -> Value -> Converter r
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Number or Null" Value
v

-- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number
-- when @value@ is a 'Number' with exponent less than or equal to 1024.
withBoundedScientific :: T.Text -> (Scientific -> Converter a) -> Value ->  Converter a
{-# INLINE withBoundedScientific #-}
withBoundedScientific :: Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
name Scientific -> Converter a
f (Number Scientific
x)
    | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1024 = Scientific -> Converter a
f Scientific
x
    | Bool
otherwise = Text -> Converter a
forall a. Text -> Converter a
fail' (Text -> Converter a)
-> (Builder () -> Text) -> Builder () -> Converter a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter a) -> Builder () -> Converter a
forall a b. (a -> b) -> a -> b
$ do
        Builder ()
"converting "
        Text -> Builder ()
T.text Text
name
        Builder ()
" failed, found a number with exponent "
        Int -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
T.int Int
e
        Builder ()
", but it must not be greater than 1024"
  where e :: Int
e = Scientific -> Int
base10Exponent Scientific
x
withBoundedScientific Text
name Scientific -> Converter a
_ Value
v = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Number" Value
v

-- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number
-- when @value@ is a 'Number' and value is within @minBound ~ maxBound@.
withBoundedIntegral :: (Bounded a, Integral a) => T.Text -> (a -> Converter r) -> Value -> Converter r
{-# INLINE withBoundedIntegral #-}
withBoundedIntegral :: Text -> (a -> Converter r) -> Value -> Converter r
withBoundedIntegral Text
name a -> Converter r
f (Number Scientific
x) =
    case Scientific -> Maybe a
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
x of
        Just a
i -> a -> Converter r
f a
i
        Maybe a
_      -> Text -> Converter r
forall a. Text -> Converter a
fail' (Text -> Converter r)
-> (Builder () -> Text) -> Builder () -> Converter r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter r) -> Builder () -> Converter r
forall a b. (a -> b) -> a -> b
$ do
            Builder ()
"converting "
            Text -> Builder ()
T.text Text
name
            Builder ()
"failed, value is either floating or will cause over or underflow: "
            Scientific -> Builder ()
T.scientific Scientific
x
withBoundedIntegral Text
name a -> Converter r
_ Value
v = Text -> Text -> Value -> Converter r
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Number" Value
v

withText :: T.Text -> (T.Text -> Converter a) -> Value -> Converter a
{-# INLINE withText #-}
withText :: Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
_    Text -> Converter a
f (String Text
x) = Text -> Converter a
f Text
x
withText Text
name Text -> Converter a
_ Value
v          = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"String" Value
v

withArray :: T.Text -> (V.Vector Value -> Converter a) -> Value -> Converter a
{-# INLINE withArray #-}
withArray :: Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
_ Vector Value -> Converter a
f (Array Vector Value
arr) = Vector Value -> Converter a
f Vector Value
arr
withArray Text
name Vector Value -> Converter a
_ Value
v        = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Array" Value
v

-- | Directly use 'Object' as key-values for further converting.
withKeyValues :: T.Text -> (V.Vector (T.Text, Value) -> Converter a) -> Value -> Converter a
{-# INLINE withKeyValues #-}
withKeyValues :: Text
-> (Vector (Text, Value) -> Converter a) -> Value -> Converter a
withKeyValues Text
_    Vector (Text, Value) -> Converter a
f (Object Vector (Text, Value)
kvs) = Vector (Text, Value) -> Converter a
f Vector (Text, Value)
kvs
withKeyValues Text
name Vector (Text, Value) -> Converter a
_ Value
v            = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Object" Value
v

-- | Take a 'Object' as an 'FM.FlatMap T.Text Value', on key duplication prefer first one.
withFlatMap :: T.Text -> (FM.FlatMap T.Text Value -> Converter a) -> Value -> Converter a
{-# INLINE withFlatMap #-}
withFlatMap :: Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMap Text
_    FlatMap Text Value -> Converter a
f (Object Vector (Text, Value)
obj) = FlatMap Text Value -> Converter a
f (Vector (Text, Value) -> FlatMap Text Value
forall k v. Ord k => Vector (k, v) -> FlatMap k v
FM.packVector Vector (Text, Value)
obj)
withFlatMap Text
name FlatMap Text Value -> Converter a
_ Value
v            = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Object" Value
v

-- | Take a 'Object' as an 'FM.FlatMap T.Text Value', on key duplication prefer last one.
withFlatMapR :: T.Text -> (FM.FlatMap T.Text Value -> Converter a) -> Value -> Converter a
{-# INLINE withFlatMapR #-}
withFlatMapR :: Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
_    FlatMap Text Value -> Converter a
f (Object Vector (Text, Value)
obj) = FlatMap Text Value -> Converter a
f (Vector (Text, Value) -> FlatMap Text Value
forall k v. Ord k => Vector (k, v) -> FlatMap k v
FM.packVectorR Vector (Text, Value)
obj)
withFlatMapR Text
name FlatMap Text Value -> Converter a
_ Value
v            = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Object" Value
v

-- | Take a 'Object' as an 'HM.HashMap T.Text Value', on key duplication prefer first one.
withHashMap :: T.Text -> (HM.HashMap T.Text Value -> Converter a) -> Value -> Converter a
{-# INLINE withHashMap #-}
withHashMap :: Text -> (HashMap Text Value -> Converter a) -> Value -> Converter a
withHashMap Text
_    HashMap Text Value -> Converter a
f (Object Vector (Text, Value)
obj) = HashMap Text Value -> Converter a
f ([(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList (Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpackR Vector (Text, Value)
obj))
withHashMap Text
name HashMap Text Value -> Converter a
_ Value
v            = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Object" Value
v

-- | Take a 'Object' as an 'HM.HashMap T.Text Value', on key duplication prefer last one.
withHashMapR :: T.Text -> (HM.HashMap T.Text Value -> Converter a) -> Value -> Converter a
{-# INLINE withHashMapR #-}
withHashMapR :: Text -> (HashMap Text Value -> Converter a) -> Value -> Converter a
withHashMapR Text
_    HashMap Text Value -> Converter a
f (Object Vector (Text, Value)
obj) = HashMap Text Value -> Converter a
f ([(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList (Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Text, Value)
obj))
withHashMapR Text
name HashMap Text Value -> Converter a
_ Value
v            = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Object" Value
v

-- | Decode a nested JSON-encoded string.
withEmbeddedJSON :: T.Text                  -- ^ data type name
                 -> (Value -> Converter a)     -- ^ a inner converter which will get the converted 'Value'.
                 -> Value -> Converter a       -- a converter take a JSON String
{-# INLINE withEmbeddedJSON #-}
withEmbeddedJSON :: Text -> (Value -> Converter a) -> Value -> Converter a
withEmbeddedJSON Text
_ Value -> Converter a
innerConverter (String Text
txt) = (forall r. ([PathElement] -> Text -> r) -> (a -> r) -> r)
-> Converter a
forall a.
(forall r. ([PathElement] -> Text -> r) -> (a -> r) -> r)
-> Converter a
Converter (\ [PathElement] -> Text -> r
kf a -> r
k ->
        case Bytes -> Either DecodeError Value
forall a. JSON a => Bytes -> Either DecodeError a
decode' (Text -> Bytes
T.getUTF8Bytes Text
txt) of
            Right Value
v -> Converter a -> ([PathElement] -> Text -> r) -> (a -> r) -> r
forall a.
Converter a
-> forall r. ([PathElement] -> Text -> r) -> (a -> r) -> r
runConverter (Value -> Converter a
innerConverter Value
v) (\ [PathElement]
paths Text
msg -> [PathElement] -> Text -> r
kf (PathElement
EmbeddedPathElement -> [PathElement] -> [PathElement]
forall a. a -> [a] -> [a]
:[PathElement]
paths) Text
msg) a -> r
k
            Left (Left ParseError
pErr) -> [PathElement] -> Text -> r
kf [] (Text -> ParseError -> Text
T.intercalate Text
", " (Text
"parsing embeded JSON failed "Text -> ParseError -> ParseError
forall a. a -> [a] -> [a]
: ParseError
pErr))
            Either DecodeError Value
_                -> [Char] -> r
forall a. HasCallStack => [Char] -> a
error [Char]
"Z.JSON.Base: impossible, converting to Value should not fail")
withEmbeddedJSON Text
name Value -> Converter a
_ Value
v = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"String" Value
v

-- | Retrieve the value associated with the given key of an 'Object'.
-- The result is 'empty' if the key is not present or the value cannot
-- be converted to the desired type.
--
-- This accessor is appropriate if the key and value /must/ be present
-- in an object for it to be valid.  If the key and value are
-- optional, use '.:?' instead.
(.:) :: (JSON a) => FM.FlatMap T.Text Value -> T.Text -> Converter a
{-# INLINE (.:) #-}
.: :: FlatMap Text Value -> Text -> Converter a
(.:) = (Value -> Converter a) -> FlatMap Text Value -> Text -> Converter a
forall a.
(Value -> Converter a) -> FlatMap Text Value -> Text -> Converter a
convertField Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue

-- | Retrieve the value associated with the given key of an 'Object'. The
-- result is 'Nothing' if the key is not present or if its value is 'Null',
-- or fail if the value cannot be converted to the desired type.
--
-- This accessor is most useful if the key and value can be absent
-- from an object without affecting its validity.  If the key and
-- value are mandatory, use '.:' instead.
(.:?) :: (JSON a) => FM.FlatMap T.Text Value -> T.Text -> Converter (Maybe a)
{-# INLINE (.:?) #-}
.:? :: FlatMap Text Value -> Text -> Converter (Maybe a)
(.:?) = (Value -> Converter a)
-> FlatMap Text Value -> Text -> Converter (Maybe a)
forall a.
(Value -> Converter a)
-> FlatMap Text Value -> Text -> Converter (Maybe a)
convertFieldMaybe Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue

-- | Retrieve the value associated with the given key of an 'Object'.
-- The result is 'Nothing' if the key is not present or fail if the
-- value cannot be converted to the desired type.
--
-- This differs from '.:?' by attempting to convert 'Null' the same as any
-- other JSON value, instead of interpreting it as 'Nothing'.
(.:!) :: (JSON a) => FM.FlatMap T.Text Value -> T.Text -> Converter (Maybe a)
{-# INLINE (.:!) #-}
.:! :: FlatMap Text Value -> Text -> Converter (Maybe a)
(.:!) = (Value -> Converter a)
-> FlatMap Text Value -> Text -> Converter (Maybe a)
forall a.
(Value -> Converter a)
-> FlatMap Text Value -> Text -> Converter (Maybe a)
convertFieldMaybe' Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue

convertField :: (Value -> Converter a)  -- ^ the field converter (value part of a key value pair)
           -> FM.FlatMap T.Text Value -> T.Text -> Converter a
{-# INLINE convertField #-}
convertField :: (Value -> Converter a) -> FlatMap Text Value -> Text -> Converter a
convertField Value -> Converter a
p FlatMap Text Value
obj Text
key = case Text -> FlatMap Text Value -> Maybe Value
forall k v. Ord k => k -> FlatMap k v -> Maybe v
FM.lookup Text
key FlatMap Text Value
obj of
    Just Value
v -> Value -> Converter a
p Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
key
    Maybe Value
_      -> Text -> Converter a
forall a. Text -> Converter a
fail' (ParseError -> Text
T.concat (ParseError -> Text) -> ParseError -> Text
forall a b. (a -> b) -> a -> b
$ [Text
"key ", Text
key, Text
" not present"])

-- | Variant of '.:?' with explicit converter function.
convertFieldMaybe :: (Value -> Converter a) -> FM.FlatMap T.Text Value -> T.Text -> Converter (Maybe a)
{-# INLINE convertFieldMaybe #-}
convertFieldMaybe :: (Value -> Converter a)
-> FlatMap Text Value -> Text -> Converter (Maybe a)
convertFieldMaybe Value -> Converter a
p FlatMap Text Value
obj Text
key = case Text -> FlatMap Text Value -> Maybe Value
forall k v. Ord k => k -> FlatMap k v -> Maybe v
FM.lookup Text
key FlatMap Text Value
obj of
    Just Value
Null -> Maybe a -> Converter (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just Value
v    -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Converter a -> Converter (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Converter a
p Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
key
    Maybe Value
_         -> Maybe a -> Converter (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | Variant of '.:!' with explicit converter function.
convertFieldMaybe' :: (Value -> Converter a) -> FM.FlatMap T.Text Value -> T.Text -> Converter (Maybe a)
{-# INLINE convertFieldMaybe' #-}
convertFieldMaybe' :: (Value -> Converter a)
-> FlatMap Text Value -> Text -> Converter (Maybe a)
convertFieldMaybe' Value -> Converter a
p FlatMap Text Value
obj Text
key = case Text -> FlatMap Text Value -> Maybe Value
forall k v. Ord k => k -> FlatMap k v -> Maybe v
FM.lookup Text
key FlatMap Text Value
obj of
    Just Value
v -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Converter a -> Converter (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Converter a
p Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
key
    Maybe Value
_      -> Maybe a -> Converter (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

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

-- | Use @,@ as separator to connect list of builders.
commaSepList :: JSON a => [a] -> B.Builder ()
{-# INLINE commaSepList #-}
commaSepList :: [a] -> Builder ()
commaSepList = Builder () -> (a -> Builder ()) -> [a] -> Builder ()
forall a. Builder () -> (a -> Builder ()) -> [a] -> Builder ()
B.intercalateList Builder ()
B.comma a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON

-- | Use @,@ as separator to connect a vector of builders.
commaSepVec :: (JSON a, V.Vec v a) => v a ->  B.Builder ()
{-# INLINE commaSepVec #-}
commaSepVec :: v a -> Builder ()
commaSepVec = Builder () -> (a -> Builder ()) -> v a -> Builder ()
forall (v :: * -> *) a.
Vec v a =>
Builder () -> (a -> Builder ()) -> v a -> Builder ()
B.intercalateVec Builder ()
B.comma a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON

-- | A newtype for 'B.Builder', whose semigroup's instance is to connect two builder with 'B.comma'.
newtype KVItem = KVItem (B.Builder ())

instance Semigroup KVItem where
    {-# INLINE (<>) #-}
    KVItem Builder ()
a <> :: KVItem -> KVItem -> KVItem
<> KVItem Builder ()
b = Builder () -> KVItem
KVItem (Builder ()
a Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
B.comma Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
b)

-- | Connect key and value to a 'KVItem' using 'B.colon', key will be escaped.
(.!) :: JSON v => T.Text -> v -> KVItem
{-# INLINE (.!) #-}
Text
k .! :: Text -> v -> KVItem
.! v
v = Builder () -> KVItem
KVItem (Text
k Text -> Builder () -> Builder ()
`JB.kv'` v -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON v
v)
infixr 8 .!

-- | Add curly for comma connected 'KVItem's.
object' :: KVItem -> B.Builder ()
{-# INLINE object' #-}
object' :: KVItem -> Builder ()
object' (KVItem Builder ()
kvb) = Builder () -> Builder ()
B.curly Builder ()
kvb

-- | Connect key and value to a tuple to be used with 'object'.
(.=) :: JSON v => T.Text -> v -> (T.Text, Value)
{-# INLINE (.=) #-}
Text
k .= :: Text -> v -> (Text, Value)
.= v
v = let !v' :: Value
v' = v -> Value
forall a. JSON a => a -> Value
toValue v
v in  (Text
k, Value
v')
infixr 8 .=

-- | Alias for @Object . pack@.
object :: [(T.Text, Value)] -> Value
{-# INLINE object #-}
object :: [(Text, Value)] -> Value
object = 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

--------------------------------------------------------------------------------
-- | Generic encode/decode Settings
--
-- There should be no control characters in formatted texts since we don't escaping those
-- field names or constructor names ('defaultSettings' relys on Haskell's lexical property).
-- Otherwise 'encodeJSON' will output illegal JSON string.
data Settings = Settings
    { Settings -> [Char] -> Text
fieldFmt  :: String -> T.Text -- ^ format field labels
    , Settings -> [Char] -> Text
constrFmt :: String -> T.Text -- ^ format constructor names
    , Settings -> Bool
missingKeyAsNull :: Bool      -- ^ take missing field as 'Null'?
    }

-- | @Settings T.pack T.pack False@
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = ([Char] -> Text) -> ([Char] -> Text) -> Bool -> Settings
Settings [Char] -> Text
T.pack [Char] -> Text
T.pack Bool
False

--------------------------------------------------------------------------------
-- GToValue
--------------------------------------------------------------------------------

class GToValue f where
    gToValue :: Settings -> f a -> Value

--------------------------------------------------------------------------------
-- Selectors

type family Field f where
    Field (a :*: b) = Field a
    Field (S1 (MetaSel Nothing u ss ds) f) = Value
    Field (S1 (MetaSel (Just l) u ss ds) f) = (T.Text, Value)

class GWriteFields f where
    gWriteFields :: Settings -> A.SmallMutableArray s (Field f) -> Int -> f a -> ST s ()

instance (ProductSize a, GWriteFields a, GWriteFields b, Field a ~ Field b) => GWriteFields (a :*: b) where
    {-# INLINE gWriteFields #-}
    gWriteFields :: Settings
-> SmallMutableArray s (Field (a :*: b))
-> Int
-> (:*:) a b a
-> ST s ()
gWriteFields Settings
s SmallMutableArray s (Field (a :*: b))
marr Int
idx (a a
a :*: b a
b) = do
        Settings -> SmallMutableArray s (Field a) -> Int -> a a -> ST s ()
forall k (f :: k -> *) s (a :: k).
GWriteFields f =>
Settings -> SmallMutableArray s (Field f) -> Int -> f a -> ST s ()
gWriteFields Settings
s SmallMutableArray s (Field a)
SmallMutableArray s (Field (a :*: b))
marr Int
idx a a
a
        Settings -> SmallMutableArray s (Field b) -> Int -> b a -> ST s ()
forall k (f :: k -> *) s (a :: k).
GWriteFields f =>
Settings -> SmallMutableArray s (Field f) -> Int -> f a -> ST s ()
gWriteFields Settings
s SmallMutableArray s (Field b)
SmallMutableArray s (Field (a :*: b))
marr (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy# a -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize (Proxy# a
forall k (a :: k). Proxy# a
proxy# :: Proxy# a)) b a
b

instance (GToValue f) => GWriteFields (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gWriteFields #-}
    gWriteFields :: Settings
-> SmallMutableArray s (Field (S1 ('MetaSel 'Nothing u ss ds) f))
-> Int
-> S1 ('MetaSel 'Nothing u ss ds) f a
-> ST s ()
gWriteFields Settings
s SmallMutableArray s (Field (S1 ('MetaSel 'Nothing u ss ds) f))
marr Int
idx (M1 f a
x) = SmallMutableArray (PrimState (ST s)) Value
-> Int -> Value -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
A.writeSmallArray SmallMutableArray s (Field (S1 ('MetaSel 'Nothing u ss ds) f))
SmallMutableArray (PrimState (ST s)) Value
marr Int
idx (Settings -> f a -> Value
forall k (f :: k -> *) (a :: k).
GToValue f =>
Settings -> f a -> Value
gToValue Settings
s f a
x)

instance (GToValue f, Selector (MetaSel (Just l) u ss ds)) => GWriteFields (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gWriteFields #-}
    gWriteFields :: Settings
-> SmallMutableArray s (Field (S1 ('MetaSel ('Just l) u ss ds) f))
-> Int
-> S1 ('MetaSel ('Just l) u ss ds) f a
-> ST s ()
gWriteFields Settings
s SmallMutableArray s (Field (S1 ('MetaSel ('Just l) u ss ds) f))
marr Int
idx m1 :: S1 ('MetaSel ('Just l) u ss ds) f a
m1@(M1 f a
x) = SmallMutableArray (PrimState (ST s)) (Text, Value)
-> Int -> (Text, Value) -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
A.writeSmallArray SmallMutableArray s (Field (S1 ('MetaSel ('Just l) u ss ds) f))
SmallMutableArray (PrimState (ST s)) (Text, Value)
marr Int
idx ((Settings -> [Char] -> Text
fieldFmt Settings
s) (S1 ('MetaSel ('Just l) u ss ds) f a -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName S1 ('MetaSel ('Just l) u ss ds) f a
m1), Settings -> f a -> Value
forall k (f :: k -> *) (a :: k).
GToValue f =>
Settings -> f a -> Value
gToValue Settings
s f a
x)

instance (GToValue f, Selector (MetaSel (Just l) u ss ds)) => GToValue (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gToValue #-}
    gToValue :: Settings -> S1 ('MetaSel ('Just l) u ss ds) f a -> Value
gToValue Settings
s m1 :: S1 ('MetaSel ('Just l) u ss ds) f a
m1@(M1 f a
x) =
        let !k :: Text
k = Settings -> [Char] -> Text
fieldFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ S1 ('MetaSel ('Just l) u ss ds) f a -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName S1 ('MetaSel ('Just l) u ss ds) f a
m1
            !v :: Value
v = Settings -> f a -> Value
forall k (f :: k -> *) (a :: k).
GToValue f =>
Settings -> f a -> Value
gToValue Settings
s f a
x
        in Vector (Text, Value) -> Value
Object ((Text, Value) -> Vector (Text, Value)
forall (v :: * -> *) a. Vec v a => a -> v a
V.singleton (Text
k, Value
v))

instance GToValue f => GToValue (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gToValue #-}
    gToValue :: Settings -> S1 ('MetaSel 'Nothing u ss ds) f a -> Value
gToValue Settings
s (M1 f a
x) = Settings -> f a -> Value
forall k (f :: k -> *) (a :: k).
GToValue f =>
Settings -> f a -> Value
gToValue Settings
s f a
x

instance JSON a => GToValue (K1 i a) where
    {-# INLINE gToValue #-}
    gToValue :: Settings -> K1 i a a -> Value
gToValue Settings
_ (K1 a
x) = a -> Value
forall a. JSON a => a -> Value
toValue a
x

class GMergeFields f where
    gMergeFields :: Proxy# f -> A.SmallMutableArray s (Field f) -> ST s Value

instance GMergeFields a => GMergeFields (a :*: b) where
    {-# INLINE gMergeFields #-}
    gMergeFields :: Proxy# (a :*: b)
-> SmallMutableArray s (Field (a :*: b)) -> ST s Value
gMergeFields Proxy# (a :*: b)
_ = Proxy# a -> SmallMutableArray s (Field a) -> ST s Value
forall k (f :: k -> *) s.
GMergeFields f =>
Proxy# f -> SmallMutableArray s (Field f) -> ST s Value
gMergeFields (Proxy# a
forall k (a :: k). Proxy# a
proxy# :: Proxy# a)

instance GMergeFields (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gMergeFields #-}
    gMergeFields :: Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
-> SmallMutableArray s (Field (S1 ('MetaSel 'Nothing u ss ds) f))
-> ST s Value
gMergeFields Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
_ SmallMutableArray s (Field (S1 ('MetaSel 'Nothing u ss ds) f))
marr = do
        SmallArray Value
arr <- SmallMutableArray (PrimState (ST s)) Value
-> ST s (SmallArray Value)
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
A.unsafeFreezeSmallArray SmallMutableArray s (Field (S1 ('MetaSel 'Nothing u ss ds) f))
SmallMutableArray (PrimState (ST s)) Value
marr
        let l :: Int
l = SmallArray Value -> Int
forall a. SmallArray a -> Int
A.sizeofSmallArray SmallArray Value
arr
        Value -> ST s Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Value -> Value
Array (SmallArray Value -> Int -> Int -> Vector Value
forall a. SmallArray a -> Int -> Int -> Vector a
V.Vector SmallArray Value
arr Int
0 Int
l))

instance GMergeFields (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gMergeFields #-}
    gMergeFields :: Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
-> SmallMutableArray s (Field (S1 ('MetaSel ('Just l) u ss ds) f))
-> ST s Value
gMergeFields Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
_ SmallMutableArray s (Field (S1 ('MetaSel ('Just l) u ss ds) f))
marr = do
        SmallArray (Text, Value)
arr <- SmallMutableArray (PrimState (ST s)) (Text, Value)
-> ST s (SmallArray (Text, Value))
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
A.unsafeFreezeSmallArray SmallMutableArray s (Field (S1 ('MetaSel ('Just l) u ss ds) f))
SmallMutableArray (PrimState (ST s)) (Text, Value)
marr
        let l :: Int
l = SmallArray (Text, Value) -> Int
forall a. SmallArray a -> Int
A.sizeofSmallArray SmallArray (Text, Value)
arr
        Value -> ST s Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector (Text, Value) -> Value
Object (SmallArray (Text, Value) -> Int -> Int -> Vector (Text, Value)
forall a. SmallArray a -> Int -> Int -> Vector a
V.Vector SmallArray (Text, Value)
arr Int
0 Int
l))

--------------------------------------------------------------------------------
-- Constructors

class GConstrToValue f where
    gConstrToValue :: Bool -> Settings -> f a -> Value

instance GConstrToValue V1 where
    {-# INLINE gConstrToValue #-}
    gConstrToValue :: Bool -> Settings -> V1 a -> Value
gConstrToValue Bool
_ Settings
_ V1 a
_ = [Char] -> Value
forall a. HasCallStack => [Char] -> a
error [Char]
"Z.Data.JSON.Base: empty data type"

instance (GConstrToValue f, GConstrToValue g) => GConstrToValue (f :+: g) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue :: Bool -> Settings -> (:+:) f g a -> Value
gConstrToValue Bool
_ Settings
s (L1 f a
x) = Bool -> Settings -> f a -> Value
forall k (f :: k -> *) (a :: k).
GConstrToValue f =>
Bool -> Settings -> f a -> Value
gConstrToValue Bool
True Settings
s f a
x
    gConstrToValue Bool
_ Settings
s (R1 g a
x) = Bool -> Settings -> g a -> Value
forall k (f :: k -> *) (a :: k).
GConstrToValue f =>
Bool -> Settings -> f a -> Value
gConstrToValue Bool
True Settings
s g a
x

-- | Constructor without payload, convert to String
instance (Constructor c) => GConstrToValue (C1 c U1) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue :: Bool -> Settings -> C1 c U1 a -> Value
gConstrToValue Bool
_ Settings
s (M1 U1 a
_) = Text -> Value
String (Text -> Value) -> ([Char] -> Text) -> [Char] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Value) -> [Char] -> Value
forall a b. (a -> b) -> a -> b
$ Any c U1 Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall k k (t :: Meta -> (k -> *) -> k -> *) (a :: k). t c U1 a
forall a. HasCallStack => a
undefined :: t c U1 a)

-- | Constructor with a single payload
instance (Constructor c, GToValue (S1 sc f)) => GConstrToValue (C1 c (S1 sc f)) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue :: Bool -> Settings -> C1 c (S1 sc f) a -> Value
gConstrToValue Bool
False Settings
s (M1 S1 sc f a
x) = Settings -> S1 sc f a -> Value
forall k (f :: k -> *) (a :: k).
GToValue f =>
Settings -> f a -> Value
gToValue Settings
s S1 sc f a
x
    gConstrToValue Bool
True Settings
s (M1 S1 sc f a
x) =
        let !k :: Text
k = Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined
            !v :: Value
v = Settings -> S1 sc f a -> Value
forall k (f :: k -> *) (a :: k).
GToValue f =>
Settings -> f a -> Value
gToValue Settings
s S1 sc f a
x
        in Vector (Text, Value) -> Value
Object ((Text, Value) -> Vector (Text, Value)
forall (v :: * -> *) a. Vec v a => a -> v a
V.singleton (Text
k, Value
v))

-- | Constructor with multiple payloads
instance (ProductSize (a :*: b), GWriteFields (a :*: b), GMergeFields (a :*: b), Constructor c)
    => GConstrToValue (C1 c (a :*: b)) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue :: Bool -> Settings -> C1 c (a :*: b) a -> Value
gConstrToValue Bool
False Settings
s (M1 (:*:) a b a
x) = (forall s. ST s Value) -> Value
forall a. (forall s. ST s a) -> a
runST (do
        SmallMutableArray s (Field a)
marr <- Int
-> Field a -> ST s (SmallMutableArray (PrimState (ST s)) (Field a))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
A.newSmallArray (Proxy# (a :*: b) -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b))) Field a
forall a. HasCallStack => a
undefined
        Settings
-> SmallMutableArray s (Field (a :*: b))
-> Int
-> (:*:) a b a
-> ST s ()
forall k (f :: k -> *) s (a :: k).
GWriteFields f =>
Settings -> SmallMutableArray s (Field f) -> Int -> f a -> ST s ()
gWriteFields Settings
s SmallMutableArray s (Field a)
SmallMutableArray s (Field (a :*: b))
marr Int
0 (:*:) a b a
x
        Proxy# (a :*: b)
-> SmallMutableArray s (Field (a :*: b)) -> ST s Value
forall k (f :: k -> *) s.
GMergeFields f =>
Proxy# f -> SmallMutableArray s (Field f) -> ST s Value
gMergeFields (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)) SmallMutableArray s (Field a)
SmallMutableArray s (Field (a :*: b))
marr)
    gConstrToValue Bool
True Settings
s (M1 (:*:) a b a
x) =
        let !k :: Text
k = Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined
            !v :: Value
v = (forall s. ST s Value) -> Value
forall a. (forall s. ST s a) -> a
runST (do
                    SmallMutableArray s (Field a)
marr <- Int
-> Field a -> ST s (SmallMutableArray (PrimState (ST s)) (Field a))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
A.newSmallArray (Proxy# (a :*: b) -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b))) Field a
forall a. HasCallStack => a
undefined
                    Settings
-> SmallMutableArray s (Field (a :*: b))
-> Int
-> (:*:) a b a
-> ST s ()
forall k (f :: k -> *) s (a :: k).
GWriteFields f =>
Settings -> SmallMutableArray s (Field f) -> Int -> f a -> ST s ()
gWriteFields Settings
s SmallMutableArray s (Field a)
SmallMutableArray s (Field (a :*: b))
marr Int
0 (:*:) a b a
x
                    Proxy# (a :*: b)
-> SmallMutableArray s (Field (a :*: b)) -> ST s Value
forall k (f :: k -> *) s.
GMergeFields f =>
Proxy# f -> SmallMutableArray s (Field f) -> ST s Value
gMergeFields (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)) SmallMutableArray s (Field a)
SmallMutableArray s (Field (a :*: b))
marr)
        in Vector (Text, Value) -> Value
Object ((Text, Value) -> Vector (Text, Value)
forall (v :: * -> *) a. Vec v a => a -> v a
V.singleton (Text
k, Value
v))

--------------------------------------------------------------------------------
-- Data types
instance GConstrToValue f => GToValue (D1 c f) where
    {-# INLINE gToValue #-}
    gToValue :: Settings -> D1 c f a -> Value
gToValue Settings
s (M1 f a
x) = Bool -> Settings -> f a -> Value
forall k (f :: k -> *) (a :: k).
GConstrToValue f =>
Bool -> Settings -> f a -> Value
gConstrToValue Bool
False Settings
s f a
x

--------------------------------------------------------------------------------
-- JSON
--------------------------------------------------------------------------------

class GEncodeJSON f where
    gEncodeJSON :: Settings -> f a -> B.Builder ()

--------------------------------------------------------------------------------
-- Selectors

instance (GEncodeJSON f, Selector (MetaSel (Just l) u ss ds)) => GEncodeJSON (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gEncodeJSON #-}
    gEncodeJSON :: Settings -> S1 ('MetaSel ('Just l) u ss ds) f a -> Builder ()
gEncodeJSON Settings
s m1 :: S1 ('MetaSel ('Just l) u ss ds) f a
m1@(M1 f a
x) = (Settings -> [Char] -> Text
fieldFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ S1 ('MetaSel ('Just l) u ss ds) f a -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName S1 ('MetaSel ('Just l) u ss ds) f a
m1) Text -> Builder () -> Builder ()
`JB.kv` Settings -> f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s f a
x

instance GEncodeJSON f => GEncodeJSON (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gEncodeJSON #-}
    gEncodeJSON :: Settings -> S1 ('MetaSel 'Nothing u ss ds) f a -> Builder ()
gEncodeJSON Settings
s (M1 f a
x) = Settings -> f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s f a
x

instance (GEncodeJSON a, GEncodeJSON b) => GEncodeJSON (a :*: b) where
    {-# INLINE gEncodeJSON #-}
    gEncodeJSON :: Settings -> (:*:) a b a -> Builder ()
gEncodeJSON Settings
s (a a
a :*: b a
b) = Settings -> a a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s a a
a Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
B.comma Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Settings -> b a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s b a
b

instance JSON a => GEncodeJSON (K1 i a) where
    {-# INLINE gEncodeJSON #-}
    gEncodeJSON :: Settings -> K1 i a a -> Builder ()
gEncodeJSON Settings
_ (K1 a
x) = a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON a
x

class GAddPunctuation (f :: * -> *) where
    gAddPunctuation :: Proxy# f -> B.Builder () -> B.Builder ()

instance GAddPunctuation a => GAddPunctuation (a :*: b) where
    {-# INLINE gAddPunctuation #-}
    gAddPunctuation :: Proxy# (a :*: b) -> Builder () -> Builder ()
gAddPunctuation Proxy# (a :*: b)
_ = Proxy# a -> Builder () -> Builder ()
forall (f :: * -> *).
GAddPunctuation f =>
Proxy# f -> Builder () -> Builder ()
gAddPunctuation (Proxy# a
forall k (a :: k). Proxy# a
proxy# :: Proxy# a)

instance GAddPunctuation (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gAddPunctuation #-}
    gAddPunctuation :: Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
-> Builder () -> Builder ()
gAddPunctuation Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
_ Builder ()
b = Builder () -> Builder ()
B.square Builder ()
b

instance GAddPunctuation (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gAddPunctuation #-}
    gAddPunctuation :: Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
-> Builder () -> Builder ()
gAddPunctuation Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
_ Builder ()
b = Builder () -> Builder ()
B.curly Builder ()
b

--------------------------------------------------------------------------------
-- Constructors

class GConstrEncodeJSON f where
    gConstrEncodeJSON :: Bool -> Settings -> f a -> B.Builder ()

instance GConstrEncodeJSON V1 where
    {-# INLINE gConstrEncodeJSON #-}
    gConstrEncodeJSON :: Bool -> Settings -> V1 a -> Builder ()
gConstrEncodeJSON Bool
_ Settings
_ V1 a
_ = [Char] -> Builder ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Z.Data.JSON.Base: empty data type"

instance (GConstrEncodeJSON f, GConstrEncodeJSON g) => GConstrEncodeJSON (f :+: g) where
    {-# INLINE gConstrEncodeJSON #-}
    gConstrEncodeJSON :: Bool -> Settings -> (:+:) f g a -> Builder ()
gConstrEncodeJSON Bool
_ Settings
s (L1 f a
x) = Bool -> Settings -> f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GConstrEncodeJSON f =>
Bool -> Settings -> f a -> Builder ()
gConstrEncodeJSON Bool
True Settings
s f a
x
    gConstrEncodeJSON Bool
_ Settings
s (R1 g a
x) = Bool -> Settings -> g a -> Builder ()
forall k (f :: k -> *) (a :: k).
GConstrEncodeJSON f =>
Bool -> Settings -> f a -> Builder ()
gConstrEncodeJSON Bool
True Settings
s g a
x

-- | Constructor without payload, convert to String
instance (Constructor c) => GConstrEncodeJSON (C1 c U1) where
    {-# INLINE gConstrEncodeJSON #-}
    -- There should be no chars need escaping in constructor name
    gConstrEncodeJSON :: Bool -> Settings -> C1 c U1 a -> Builder ()
gConstrEncodeJSON Bool
_ Settings
s (M1 U1 a
_) = Builder () -> Builder ()
B.quotes (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$
        Text -> Builder ()
B.text (Text -> Builder ()) -> ([Char] -> Text) -> [Char] -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Builder ()) -> [Char] -> Builder ()
forall a b. (a -> b) -> a -> b
$ Any c U1 Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall k k (t :: Meta -> (k -> *) -> k -> *) (a :: k). t c U1 a
forall a. HasCallStack => a
undefined :: t c U1 a)

-- | Constructor with a single payload
instance (Constructor c, GEncodeJSON (S1 (MetaSel Nothing u ss ds) f))
    => GConstrEncodeJSON (C1 c (S1 (MetaSel Nothing u ss ds) f)) where
    {-# INLINE gConstrEncodeJSON #-}
    gConstrEncodeJSON :: Bool
-> Settings
-> C1 c (S1 ('MetaSel 'Nothing u ss ds) f) a
-> Builder ()
gConstrEncodeJSON Bool
False Settings
s (M1 S1 ('MetaSel 'Nothing u ss ds) f a
x) = Settings -> S1 ('MetaSel 'Nothing u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s S1 ('MetaSel 'Nothing u ss ds) f a
x
    gConstrEncodeJSON Bool
True Settings
s (M1 S1 ('MetaSel 'Nothing u ss ds) f a
x) = Builder () -> Builder ()
B.curly (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
        (Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined) Text -> Builder () -> Builder ()
`JB.kv` Settings -> S1 ('MetaSel 'Nothing u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s S1 ('MetaSel 'Nothing u ss ds) f a
x

instance (Constructor c, GEncodeJSON (S1 (MetaSel (Just l) u ss ds) f))
    => GConstrEncodeJSON (C1 c (S1 (MetaSel (Just l) u ss ds) f)) where
    {-# INLINE gConstrEncodeJSON #-}
    gConstrEncodeJSON :: Bool
-> Settings
-> C1 c (S1 ('MetaSel ('Just l) u ss ds) f) a
-> Builder ()
gConstrEncodeJSON Bool
False Settings
s (M1 S1 ('MetaSel ('Just l) u ss ds) f a
x) = Builder () -> Builder ()
B.curly (Settings -> S1 ('MetaSel ('Just l) u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s S1 ('MetaSel ('Just l) u ss ds) f a
x)
    gConstrEncodeJSON Bool
True Settings
s (M1 S1 ('MetaSel ('Just l) u ss ds) f a
x) = Builder () -> Builder ()
B.curly (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
        (Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined) Text -> Builder () -> Builder ()
`JB.kv` Builder () -> Builder ()
B.curly (Settings -> S1 ('MetaSel ('Just l) u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s S1 ('MetaSel ('Just l) u ss ds) f a
x)

-- | Constructor with multiple payloads
instance (GEncodeJSON (a :*: b), GAddPunctuation (a :*: b), Constructor c)
    => GConstrEncodeJSON (C1 c (a :*: b)) where
    {-# INLINE gConstrEncodeJSON #-}
    gConstrEncodeJSON :: Bool -> Settings -> C1 c (a :*: b) a -> Builder ()
gConstrEncodeJSON Bool
False Settings
s (M1 (:*:) a b a
x) = Proxy# (a :*: b) -> Builder () -> Builder ()
forall (f :: * -> *).
GAddPunctuation f =>
Proxy# f -> Builder () -> Builder ()
gAddPunctuation (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)) (Settings -> (:*:) a b a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s (:*:) a b a
x)
    gConstrEncodeJSON Bool
True Settings
s (M1 (:*:) a b a
x) = Builder () -> Builder ()
B.curly (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
        (Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c @_ @_ @_ Any c Any Any
forall a. HasCallStack => a
undefined) Text -> Builder () -> Builder ()
`JB.kv`
            Proxy# (a :*: b) -> Builder () -> Builder ()
forall (f :: * -> *).
GAddPunctuation f =>
Proxy# f -> Builder () -> Builder ()
gAddPunctuation (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)) (Settings -> (:*:) a b a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeJSON f =>
Settings -> f a -> Builder ()
gEncodeJSON Settings
s (:*:) a b a
x)

--------------------------------------------------------------------------------
-- Data types
instance GConstrEncodeJSON f => GEncodeJSON (D1 c f) where
    {-# INLINE gEncodeJSON #-}
    gEncodeJSON :: Settings -> D1 c f a -> Builder ()
gEncodeJSON Settings
s (M1 f a
x) = Bool -> Settings -> f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GConstrEncodeJSON f =>
Bool -> Settings -> f a -> Builder ()
gConstrEncodeJSON Bool
False Settings
s f a
x

--------------------------------------------------------------------------------
-- GFromValue
--------------------------------------------------------------------------------

class GFromValue f where
    gFromValue :: Settings -> Value -> Converter (f a)

--------------------------------------------------------------------------------
-- Selectors

type family LookupTable f where
    LookupTable (a :*: b) = LookupTable a
    LookupTable (S1 (MetaSel Nothing u ss ds) f) = V.Vector Value
    LookupTable (S1 (MetaSel (Just l) u ss ds) f) = FM.FlatMap T.Text Value

class GFromFields f where
    gFromFields :: Settings -> LookupTable f -> Int -> Converter (f a)

instance (ProductSize a, GFromFields a, GFromFields b, LookupTable a ~ LookupTable b)
    => GFromFields (a :*: b) where
    {-# INLINE gFromFields #-}
    gFromFields :: Settings -> LookupTable (a :*: b) -> Int -> Converter ((:*:) a b a)
gFromFields Settings
s LookupTable (a :*: b)
v Int
idx = do
        !a a
a <- Settings -> LookupTable a -> Int -> Converter (a a)
forall k (f :: k -> *) (a :: k).
GFromFields f =>
Settings -> LookupTable f -> Int -> Converter (f a)
gFromFields Settings
s LookupTable a
LookupTable (a :*: b)
v Int
idx
        !b a
b <- Settings -> LookupTable b -> Int -> Converter (b a)
forall k (f :: k -> *) (a :: k).
GFromFields f =>
Settings -> LookupTable f -> Int -> Converter (f a)
gFromFields Settings
s LookupTable b
LookupTable (a :*: b)
v (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy# a -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize (Proxy# a
forall k (a :: k). Proxy# a
proxy# :: Proxy# a))
        (:*:) a b a -> Converter ((:*:) a b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a a
a a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
b)

instance (GFromValue f) => GFromFields (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gFromFields #-}
    gFromFields :: Settings
-> LookupTable (S1 ('MetaSel 'Nothing u ss ds) f)
-> Int
-> Converter (S1 ('MetaSel 'Nothing u ss ds) f a)
gFromFields Settings
s LookupTable (S1 ('MetaSel 'Nothing u ss ds) f)
v Int
idx = do
        Value
v' <- Vector Value -> Int -> Converter Value
forall (v :: * -> *) a (m :: * -> *).
(Vec v a, Monad m) =>
v a -> Int -> m a
V.unsafeIndexM Vector Value
LookupTable (S1 ('MetaSel 'Nothing u ss ds) f)
v Int
idx
        f a -> S1 ('MetaSel 'Nothing u ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 ('MetaSel 'Nothing u ss ds) f a)
-> Converter (f a)
-> Converter (S1 ('MetaSel 'Nothing u ss ds) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
v' Converter (f a) -> PathElement -> Converter (f a)
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
idx

instance (GFromValue f, Selector (MetaSel (Just l) u ss ds)) => GFromFields (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gFromFields #-}
    gFromFields :: Settings
-> LookupTable (S1 ('MetaSel ('Just l) u ss ds) f)
-> Int
-> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
gFromFields Settings
s LookupTable (S1 ('MetaSel ('Just l) u ss ds) f)
v Int
_ = do
        case Text -> FlatMap Text Value -> Maybe Value
forall k v. Ord k => k -> FlatMap k v -> Maybe v
FM.lookup Text
fn FlatMap Text Value
LookupTable (S1 ('MetaSel ('Just l) u ss ds) f)
v of
            Just Value
v' -> f a -> S1 ('MetaSel ('Just l) u ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 ('MetaSel ('Just l) u ss ds) f a)
-> Converter (f a)
-> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
v' Converter (f a) -> PathElement -> Converter (f a)
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
fn
            Maybe Value
_ | Settings -> Bool
missingKeyAsNull Settings
s -> f a -> S1 ('MetaSel ('Just l) u ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 ('MetaSel ('Just l) u ss ds) f a)
-> Converter (f a)
-> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
Null Converter (f a) -> PathElement -> Converter (f a)
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
fn
              | Bool
otherwise -> Text -> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall a. Text -> Converter a
fail' (Text
"Z.Data.JSON.Base: missing field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
fn)
      where
        fn :: Text
fn = (Settings -> [Char] -> Text
fieldFmt Settings
s) (M1 S ('MetaSel ('Just l) u ss ds) f Any -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName (forall (a :: k). M1 S ('MetaSel ('Just l) u ss ds) f a
forall a. HasCallStack => a
undefined :: S1 (MetaSel (Just l) u ss ds) f a))

instance GFromValue f => GFromValue (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gFromValue #-}
    gFromValue :: Settings -> Value -> Converter (S1 ('MetaSel 'Nothing u ss ds) f a)
gFromValue Settings
s Value
x = f a -> S1 ('MetaSel 'Nothing u ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 ('MetaSel 'Nothing u ss ds) f a)
-> Converter (f a)
-> Converter (S1 ('MetaSel 'Nothing u ss ds) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
x

instance (GFromValue f, Selector (MetaSel (Just l) u ss ds)) => GFromValue (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gFromValue #-}
    gFromValue :: Settings
-> Value -> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
gFromValue Settings
s (Object Vector (Text, Value)
v) = do
        case Text -> FlatMap Text Value -> Maybe Value
forall k v. Ord k => k -> FlatMap k v -> Maybe v
FM.lookup Text
fn (Vector (Text, Value) -> FlatMap Text Value
forall k v. Ord k => Vector (k, v) -> FlatMap k v
FM.packVectorR Vector (Text, Value)
v) of
            Just Value
v' -> f a -> S1 ('MetaSel ('Just l) u ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 ('MetaSel ('Just l) u ss ds) f a)
-> Converter (f a)
-> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
v' Converter (f a) -> PathElement -> Converter (f a)
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
fn
            Maybe Value
_ | Settings -> Bool
missingKeyAsNull Settings
s -> f a -> S1 ('MetaSel ('Just l) u ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 ('MetaSel ('Just l) u ss ds) f a)
-> Converter (f a)
-> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
Null Converter (f a) -> PathElement -> Converter (f a)
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
fn
              | Bool
otherwise -> Text -> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall a. Text -> Converter a
fail' (Text
"Z.Data.JSON.Base: missing field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
fn)
      where fn :: Text
fn = (Settings -> [Char] -> Text
fieldFmt Settings
s) (M1 S ('MetaSel ('Just l) u ss ds) f Any -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName (forall (a :: k). M1 S ('MetaSel ('Just l) u ss ds) f a
forall a. HasCallStack => a
undefined :: S1 (MetaSel (Just l) u ss ds) f a))
    gFromValue Settings
s Value
v = Text
-> Text -> Value -> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall a. Text -> Text -> Value -> Converter a
typeMismatch (Text
"field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fn) Text
"Object" Value
v Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
-> PathElement -> Converter (S1 ('MetaSel ('Just l) u ss ds) f a)
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
fn
      where fn :: Text
fn = (Settings -> [Char] -> Text
fieldFmt Settings
s) (M1 S ('MetaSel ('Just l) u ss ds) f Any -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName (forall (a :: k). M1 S ('MetaSel ('Just l) u ss ds) f a
forall a. HasCallStack => a
undefined :: S1 (MetaSel (Just l) u ss ds) f a))

instance JSON a => GFromValue (K1 i a) where
    {-# INLINE gFromValue #-}
    gFromValue :: Settings -> Value -> Converter (K1 i a a)
gFromValue Settings
_ Value
x = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> Converter a -> Converter (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
x

class GBuildLookup f where
    gBuildLookup :: Proxy# f -> Int -> T.Text -> Value -> Converter (LookupTable f)

instance (GBuildLookup a, GBuildLookup b) => GBuildLookup (a :*: b) where
    {-# INLINE gBuildLookup #-}
    gBuildLookup :: Proxy# (a :*: b)
-> Int -> Text -> Value -> Converter (LookupTable (a :*: b))
gBuildLookup Proxy# (a :*: b)
_ Int
siz = Proxy# a -> Int -> Text -> Value -> Converter (LookupTable a)
forall k (f :: k -> *).
GBuildLookup f =>
Proxy# f -> Int -> Text -> Value -> Converter (LookupTable f)
gBuildLookup (Proxy# a
forall k (a :: k). Proxy# a
proxy# :: Proxy# a) Int
siz

instance GBuildLookup (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gBuildLookup #-}
    gBuildLookup :: Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
-> Int
-> Text
-> Value
-> Converter (LookupTable (S1 ('MetaSel 'Nothing u ss ds) f))
gBuildLookup Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
_ Int
siz Text
name (Array Vector Value
v)
        -- we have to check size here to use 'unsafeIndexM' later
        | Int
siz' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
siz = Text -> Converter (Vector Value)
forall a. Text -> Converter a
fail' (Text -> Converter (Vector Value))
-> (Builder () -> Text) -> Builder () -> Converter (Vector Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter (Vector Value))
-> Builder () -> Converter (Vector Value)
forall a b. (a -> b) -> a -> b
$ do
            Builder ()
"converting "
            Text -> Builder ()
T.text Text
name
            Builder ()
" failed, product size mismatch, expected "
            Int -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
T.int Int
siz
            Builder ()
", get"
            Int -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
T.int Int
siz'
        | Bool
otherwise = Vector Value -> Converter (Vector Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector Value
v
      where siz' :: Int
siz' = Vector Value -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Vector Value
v
    gBuildLookup Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
_ Int
_   Text
name Value
x         = Text -> Text -> Value -> Converter (Vector Value)
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Array" Value
x

instance GBuildLookup (S1 ((MetaSel (Just l) u ss ds)) f) where
    {-# INLINE gBuildLookup #-}
    -- we don't check size, so that duplicated keys are preserved
    gBuildLookup :: Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
-> Int
-> Text
-> Value
-> Converter (LookupTable (S1 ('MetaSel ('Just l) u ss ds) f))
gBuildLookup Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
_ Int
_ Text
_ (Object Vector (Text, Value)
v) = FlatMap Text Value -> Converter (FlatMap Text Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlatMap Text Value -> Converter (FlatMap Text Value))
-> FlatMap Text Value -> Converter (FlatMap Text Value)
forall a b. (a -> b) -> a -> b
$! Vector (Text, Value) -> FlatMap Text Value
forall k v. Ord k => Vector (k, v) -> FlatMap k v
FM.packVectorR Vector (Text, Value)
v
    gBuildLookup Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
_ Int
_ Text
name Value
x       = Text -> Text -> Value -> Converter (FlatMap Text Value)
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Object" Value
x

--------------------------------------------------------------------------------
-- Constructors

class GConstrFromValue f where
    gConstrFromValue :: Bool    -- ^ Is this a sum type(more than one constructor)?
                     -> Settings -> Value -> Converter (f a)

instance GConstrFromValue V1 where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue :: Bool -> Settings -> Value -> Converter (V1 a)
gConstrFromValue Bool
_ Settings
_ Value
_ = [Char] -> Converter (V1 a)
forall a. HasCallStack => [Char] -> a
error [Char]
"Z.Data.JSON.Base: empty data type"

instance (GConstrFromValue f, GConstrFromValue g) => GConstrFromValue (f :+: g) where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue :: Bool -> Settings -> Value -> Converter ((:+:) f g a)
gConstrFromValue Bool
_ Settings
s Value
x = (f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a) -> Converter (f a) -> Converter ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GConstrFromValue f =>
Bool -> Settings -> Value -> Converter (f a)
gConstrFromValue Bool
True Settings
s Value
x) Converter ((:+:) f g a)
-> Converter ((:+:) f g a) -> Converter ((:+:) f g a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a) -> Converter (g a) -> Converter ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Settings -> Value -> Converter (g a)
forall k (f :: k -> *) (a :: k).
GConstrFromValue f =>
Bool -> Settings -> Value -> Converter (f a)
gConstrFromValue Bool
True Settings
s Value
x)

-- | Constructor without payload, convert to String
instance (Constructor c) => GConstrFromValue (C1 c U1) where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue :: Bool -> Settings -> Value -> Converter (C1 c U1 a)
gConstrFromValue Bool
_ Settings
s (String Text
x)
        | Text
cn Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x   = C1 c U1 a -> Converter (C1 c U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (U1 a -> C1 c U1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 a
forall k (p :: k). U1 p
U1)
        | Bool
otherwise = Text -> Converter (C1 c U1 a)
forall a. Text -> Converter a
fail' (Text -> Converter (C1 c U1 a))
-> (ParseError -> Text) -> ParseError -> Converter (C1 c U1 a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> Text
T.concat (ParseError -> Converter (C1 c U1 a))
-> ParseError -> Converter (C1 c U1 a)
forall a b. (a -> b) -> a -> b
$ [Text
"converting ", Text
cn', Text
"failed, unknown constructor name ", Text
x]
      where cn :: Text
cn = Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c U1 Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall k k (t :: Meta -> (k -> *) -> k -> *) (a :: k). t c U1 a
forall a. HasCallStack => a
undefined :: t c U1 a)
            cn' :: Text
cn' = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c U1 Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall k k (t :: Meta -> (k -> *) -> k -> *) (a :: k). t c U1 a
forall a. HasCallStack => a
undefined :: t c U1 a)
    gConstrFromValue Bool
_ Settings
_ Value
v = Text -> Text -> Value -> Converter (C1 c U1 a)
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
cn' Text
"String" Value
v
      where cn' :: Text
cn' = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c U1 Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall k k (t :: Meta -> (k -> *) -> k -> *) (a :: k). t c U1 a
forall a. HasCallStack => a
undefined :: t c U1 a)

-- | Constructor with a single payload
instance (Constructor c, GFromValue (S1 sc f)) => GConstrFromValue (C1 c (S1 sc f)) where
    {-# INLINE gConstrFromValue #-}
    -- | Single constructor
    gConstrFromValue :: Bool -> Settings -> Value -> Converter (C1 c (S1 sc f) a)
gConstrFromValue Bool
False Settings
s Value
x = S1 sc f a -> C1 c (S1 sc f) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (S1 sc f a -> C1 c (S1 sc f) a)
-> Converter (S1 sc f a) -> Converter (C1 c (S1 sc f) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (S1 sc f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
x
    gConstrFromValue Bool
True Settings
s Value
x = case Value
x of
        Object Vector (Text, Value)
v -> case Vector (Text, Value) -> Int -> Maybe (Text, Value)
forall (v :: * -> *) a (m :: * -> *).
(Vec v a, Monad m, HasCallStack) =>
v a -> Int -> m a
V.indexM Vector (Text, Value)
v Int
0 of
            Just (Text
k, Value
v') | Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
cn -> S1 sc f a -> C1 c (S1 sc f) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (S1 sc f a -> C1 c (S1 sc f) a)
-> Converter (S1 sc f a) -> Converter (C1 c (S1 sc f) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Value -> Converter (S1 sc f a)
forall k (f :: k -> *) (a :: k).
GFromValue f =>
Settings -> Value -> Converter (f a)
gFromValue Settings
s Value
v' Converter (S1 sc f a) -> PathElement -> Converter (S1 sc f a)
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
cn
            Maybe (Text, Value)
_                      -> Text -> Converter (C1 c (S1 sc f) a)
forall a. Text -> Converter a
fail' (Text -> Converter (C1 c (S1 sc f) a))
-> (ParseError -> Text)
-> ParseError
-> Converter (C1 c (S1 sc f) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ParseError -> Text
T.concat (ParseError -> Converter (C1 c (S1 sc f) a))
-> ParseError -> Converter (C1 c (S1 sc f) a)
forall a b. (a -> b) -> a -> b
$ [Text
"converting ", Text
cn', Text
" failed, constructor not found"]
        Value
_ ->  Text -> Text -> Value -> Converter (C1 c (S1 sc f) a)
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
cn' Text
"Object" Value
x
      where cn :: Text
cn = Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined
            cn' :: Text
cn' = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined

-- | Constructor with multiple payloads
instance (ProductSize (a :*: b), GFromFields (a :*: b), GBuildLookup (a :*: b), Constructor c)
    => GConstrFromValue (C1 c (a :*: b)) where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue :: Bool -> Settings -> Value -> Converter (C1 c (a :*: b) a)
gConstrFromValue Bool
False Settings
s Value
x = do
        LookupTable a
t <- Proxy# (a :*: b)
-> Int -> Text -> Value -> Converter (LookupTable (a :*: b))
forall k (f :: k -> *).
GBuildLookup f =>
Proxy# f -> Int -> Text -> Value -> Converter (LookupTable f)
gBuildLookup Proxy# (a :*: b)
p (Proxy# (a :*: b) -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize Proxy# (a :*: b)
p) Text
cn' Value
x
        (:*:) a b a -> C1 c (a :*: b) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ((:*:) a b a -> C1 c (a :*: b) a)
-> Converter ((:*:) a b a) -> Converter (C1 c (a :*: b) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> LookupTable (a :*: b) -> Int -> Converter ((:*:) a b a)
forall k (f :: k -> *) (a :: k).
GFromFields f =>
Settings -> LookupTable f -> Int -> Converter (f a)
gFromFields Settings
s LookupTable a
LookupTable (a :*: b)
t Int
0
      where cn' :: Text
cn' = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined
            p :: Proxy# (a :*: b)
p = Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)
    gConstrFromValue Bool
True Settings
s Value
x = case Value
x of
        Object Vector (Text, Value)
v -> case Vector (Text, Value) -> Int -> Maybe (Text, Value)
forall (v :: * -> *) a (m :: * -> *).
(Vec v a, Monad m, HasCallStack) =>
v a -> Int -> m a
V.indexM Vector (Text, Value)
v Int
0 of
            Just (Text
k, Value
v') | Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
cn -> do LookupTable a
t <- Proxy# (a :*: b)
-> Int -> Text -> Value -> Converter (LookupTable (a :*: b))
forall k (f :: k -> *).
GBuildLookup f =>
Proxy# f -> Int -> Text -> Value -> Converter (LookupTable f)
gBuildLookup Proxy# (a :*: b)
p (Proxy# (a :*: b) -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize Proxy# (a :*: b)
p) Text
cn' Value
v'
                                         (:*:) a b a -> C1 c (a :*: b) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ((:*:) a b a -> C1 c (a :*: b) a)
-> Converter ((:*:) a b a) -> Converter (C1 c (a :*: b) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> LookupTable (a :*: b) -> Int -> Converter ((:*:) a b a)
forall k (f :: k -> *) (a :: k).
GFromFields f =>
Settings -> LookupTable f -> Int -> Converter (f a)
gFromFields Settings
s LookupTable a
LookupTable (a :*: b)
t Int
0
            Maybe (Text, Value)
_                      -> Text -> Converter (C1 c (a :*: b) a)
forall a. Text -> Converter a
fail' (Text -> Converter (C1 c (a :*: b) a))
-> (ParseError -> Text)
-> ParseError
-> Converter (C1 c (a :*: b) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ParseError -> Text
T.concat (ParseError -> Converter (C1 c (a :*: b) a))
-> ParseError -> Converter (C1 c (a :*: b) a)
forall a b. (a -> b) -> a -> b
$ [Text
"converting ", Text
cn', Text
" failed, constructor not found"]
        Value
_ ->  Text -> Text -> Value -> Converter (C1 c (a :*: b) a)
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
cn' Text
"Object" Value
x
      where cn :: Text
cn = Settings -> [Char] -> Text
constrFmt Settings
s ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined
            cn' :: Text
cn' = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined
            p :: Proxy# (a :*: b)
p = Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)

--------------------------------------------------------------------------------
-- Data types
instance GConstrFromValue f => GFromValue (D1 c f) where
    {-# INLINE gFromValue #-}
    gFromValue :: Settings -> Value -> Converter (D1 c f a)
gFromValue Settings
s Value
x = f a -> D1 c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> D1 c f a) -> Converter (f a) -> Converter (D1 c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Settings -> Value -> Converter (f a)
forall k (f :: k -> *) (a :: k).
GConstrFromValue f =>
Bool -> Settings -> Value -> Converter (f a)
gConstrFromValue Bool
False Settings
s Value
x

--------------------------------------------------------------------------------
-- Built-in Instances
--------------------------------------------------------------------------------
-- | Use 'Null' as @Proxy a@
instance JSON (Proxy a) where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter (Proxy a)
fromValue = Text -> Proxy a -> Value -> Converter (Proxy a)
forall a. Text -> a -> Value -> Converter a
fromNull Text
"Proxy" Proxy a
forall k (t :: k). Proxy t
Proxy;
    {-# INLINE toValue #-}; toValue :: Proxy a -> Value
toValue Proxy a
_ = Value
Null;
    {-# INLINE encodeJSON #-}; encodeJSON :: Proxy a -> Builder ()
encodeJSON Proxy a
_ = Builder ()
"null";

instance JSON Value   where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Value
fromValue = Value -> Converter Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Value -> Value
toValue = Value -> Value
forall a. a -> a
id;
    {-# INLINE encodeJSON #-}; encodeJSON :: Value -> Builder ()
encodeJSON = Value -> Builder ()
JB.value;

instance JSON T.Text   where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Text
fromValue = Text -> (Text -> Converter Text) -> Value -> Converter Text
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"Text" Text -> Converter Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Text -> Value
toValue = Text -> Value
String;
    {-# INLINE encodeJSON #-}; encodeJSON :: Text -> Builder ()
encodeJSON = Text -> Builder ()
JB.string;

-- | Note this instance doesn't reject large input
instance JSON Scientific where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Scientific
fromValue = Text
-> (Scientific -> Converter Scientific)
-> Value
-> Converter Scientific
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withScientific Text
"Scientific" Scientific -> Converter Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Scientific -> Value
toValue = Scientific -> Value
Number;
    {-# INLINE encodeJSON #-}; encodeJSON :: Scientific -> Builder ()
encodeJSON = Scientific -> Builder ()
JB.scientific;

-- | default instance prefer later key
instance JSON a => JSON (FM.FlatMap T.Text a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (FlatMap Text a)
fromValue = Text
-> (FlatMap Text Value -> Converter (FlatMap Text a))
-> Value
-> Converter (FlatMap Text a)
forall a.
Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"Z.Data.Vector.FlatMap.FlatMap"
        ((Text -> Value -> Converter a)
-> FlatMap Text Value -> Converter (FlatMap Text a)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> FlatMap k a -> t (FlatMap k b)
FM.traverseWithKey ((Text -> Value -> Converter a)
 -> FlatMap Text Value -> Converter (FlatMap Text a))
-> (Text -> Value -> Converter a)
-> FlatMap Text Value
-> Converter (FlatMap Text a)
forall a b. (a -> b) -> a -> b
$ \ Text
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
k)
    {-# INLINE toValue #-}
    toValue :: FlatMap Text a -> Value
toValue = Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> (FlatMap Text a -> Vector (Text, Value))
-> FlatMap Text a
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatMap Text Value -> Vector (Text, Value)
forall k v. FlatMap k v -> Vector (k, v)
FM.sortedKeyValues (FlatMap Text Value -> Vector (Text, Value))
-> (FlatMap Text a -> FlatMap Text Value)
-> FlatMap Text a
-> Vector (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> FlatMap Text a -> FlatMap Text Value
forall v v' k. (v -> v') -> FlatMap k v -> FlatMap k v'
FM.map' a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: FlatMap Text a -> Builder ()
encodeJSON = (a -> Builder ()) -> Vector (Text, a) -> Builder ()
forall a. (a -> Builder ()) -> Vector (Text, a) -> Builder ()
JB.object' a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON (Vector (Text, a) -> Builder ())
-> (FlatMap Text a -> Vector (Text, a))
-> FlatMap Text a
-> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatMap Text a -> Vector (Text, a)
forall k v. FlatMap k v -> Vector (k, v)
FM.sortedKeyValues

instance (Ord a, JSON a) => JSON (FS.FlatSet a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (FlatSet a)
fromValue = Text
-> (Vector Value -> Converter (FlatSet a))
-> Value
-> Converter (FlatSet a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Vector.FlatSet.FlatSet" ((Vector Value -> Converter (FlatSet a))
 -> Value -> Converter (FlatSet a))
-> (Vector Value -> Converter (FlatSet a))
-> Value
-> Converter (FlatSet a)
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        Int -> [a] -> FlatSet a
forall v. Ord v => Int -> [v] -> FlatSet v
FS.packRN (Vector Value -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Vector Value
vs) ([a] -> FlatSet a) -> Converter [a] -> Converter (FlatSet a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ((Int -> Value -> Converter a) -> [Int] -> [Value] -> Converter [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs))
    {-# INLINE toValue #-}
    toValue :: FlatSet a -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value)
-> (FlatSet a -> Vector Value) -> FlatSet a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> Vector a -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map' a -> Value
forall a. JSON a => a -> Value
toValue (Vector a -> Vector Value)
-> (FlatSet a -> Vector a) -> FlatSet a -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatSet a -> Vector a
forall v. FlatSet v -> Vector v
FS.sortedValues
    {-# INLINE encodeJSON #-}
    encodeJSON :: FlatSet a -> Builder ()
encodeJSON = (a -> Builder ()) -> Vector a -> Builder ()
forall a. (a -> Builder ()) -> Vector a -> Builder ()
JB.array' a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON (Vector a -> Builder ())
-> (FlatSet a -> Vector a) -> FlatSet a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatSet a -> Vector a
forall v. FlatSet v -> Vector v
FS.sortedValues

-- | default instance prefer later key
instance JSON a => JSON (HM.HashMap T.Text a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (HashMap Text a)
fromValue = Text
-> (HashMap Text Value -> Converter (HashMap Text a))
-> Value
-> Converter (HashMap Text a)
forall a.
Text -> (HashMap Text Value -> Converter a) -> Value -> Converter a
withHashMapR Text
"Data.HashMap.HashMap"
        ((Text -> Value -> Converter a)
-> HashMap Text Value -> Converter (HashMap Text a)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HM.traverseWithKey ((Text -> Value -> Converter a)
 -> HashMap Text Value -> Converter (HashMap Text a))
-> (Text -> Value -> Converter a)
-> HashMap Text Value
-> Converter (HashMap Text a)
forall a b. (a -> b) -> a -> b
$ \ Text
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
k)
    {-# INLINE toValue #-}
    toValue :: HashMap Text a -> Value
toValue = Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> (HashMap Text a -> Vector (Text, Value))
-> HashMap Text a
-> 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)] -> Vector (Text, Value))
-> (HashMap Text a -> [(Text, Value)])
-> HashMap Text a
-> Vector (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Text Value -> [(Text, Value)])
-> (HashMap Text a -> HashMap Text Value)
-> HashMap Text a
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> HashMap Text a -> HashMap Text Value
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: HashMap Text a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.curly (Builder () -> Builder ())
-> (HashMap Text a -> Builder ()) -> HashMap Text a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder ()
-> ((Text, a) -> Builder ()) -> [(Text, a)] -> Builder ()
forall a. Builder () -> (a -> Builder ()) -> [a] -> Builder ()
B.intercalateList Builder ()
B.comma (\ (Text
k, a
v) -> Text
k Text -> Builder () -> Builder ()
`JB.kv'` a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON a
v) ([(Text, a)] -> Builder ())
-> (HashMap Text a -> [(Text, a)]) -> HashMap Text a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text a -> [(Text, a)]
forall k v. HashMap k v -> [(k, v)]
HM.toList

instance JSON a => JSON (M.Map T.Text a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Map Text a)
fromValue = Text
-> (Vector (Text, Value) -> Converter (Map Text a))
-> Value
-> Converter (Map Text a)
forall a.
Text
-> (Vector (Text, Value) -> Converter a) -> Value -> Converter a
withKeyValues Text
"Data.Map.Map" ((Vector (Text, Value) -> Converter (Map Text a))
 -> Value -> Converter (Map Text a))
-> (Vector (Text, Value) -> Converter (Map Text a))
-> Value
-> Converter (Map Text a)
forall a b. (a -> b) -> a -> b
$
        ((Text -> Value -> Converter a)
-> Map Text Value -> Converter (Map Text a)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
M.traverseWithKey (\ Text
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
k)) (Map Text Value -> Converter (Map Text a))
-> (Vector (Text, Value) -> Map Text Value)
-> Vector (Text, Value)
-> Converter (Map Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Value)] -> Map Text Value)
-> (Vector (Text, Value) -> [(Text, Value)])
-> Vector (Text, Value)
-> Map Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack
    {-# INLINE toValue #-}
    toValue :: Map Text a -> Value
toValue = Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> (Map Text a -> Vector (Text, Value)) -> Map Text a -> 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)] -> Vector (Text, Value))
-> (Map Text a -> [(Text, Value)])
-> Map Text a
-> Vector (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text Value -> [(Text, Value)])
-> (Map Text a -> Map Text Value) -> Map Text a -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> Map Text a -> Map Text Value
forall a b k. (a -> b) -> Map k a -> Map k b
M.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: Map Text a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.curly (Builder () -> Builder ())
-> (Map Text a -> Builder ()) -> Map Text a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder ()
-> ((Text, a) -> Builder ()) -> [(Text, a)] -> Builder ()
forall a. Builder () -> (a -> Builder ()) -> [a] -> Builder ()
B.intercalateList Builder ()
B.comma (\ (Text
k, a
v) -> Text
k Text -> Builder () -> Builder ()
`JB.kv'` a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON a
v) ([(Text, a)] -> Builder ())
-> (Map Text a -> [(Text, a)]) -> Map Text a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text a -> [(Text, a)]
forall k a. Map k a -> [(k, a)]
M.toList

instance JSON a => JSON (FIM.FlatIntMap a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (FlatIntMap a)
fromValue = Text
-> (FlatMap Text Value -> Converter (FlatIntMap a))
-> Value
-> Converter (FlatIntMap a)
forall a.
Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"Z.Data.Vector.FlatIntMap.FlatIntMap" ((FlatMap Text Value -> Converter (FlatIntMap a))
 -> Value -> Converter (FlatIntMap a))
-> (FlatMap Text Value -> Converter (FlatIntMap a))
-> Value
-> Converter (FlatIntMap a)
forall a b. (a -> b) -> a -> b
$ \ FlatMap Text Value
m ->
        let kvs :: Vector (Text, Value)
kvs = FlatMap Text Value -> Vector (Text, Value)
forall k v. FlatMap k v -> Vector (k, v)
FM.sortedKeyValues FlatMap Text Value
m
        in Vector (IPair a) -> FlatIntMap a
forall v. Vector (IPair v) -> FlatIntMap v
FIM.packVectorR (Vector (IPair a) -> FlatIntMap a)
-> Converter (Vector (IPair a)) -> Converter (FlatIntMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Vector (Text, Value)
-> ((Text, Value) -> Converter (IPair a))
-> Converter (Vector (IPair a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Vector (Text, Value)
kvs (((Text, Value) -> Converter (IPair a))
 -> Converter (Vector (IPair a)))
-> ((Text, Value) -> Converter (IPair a))
-> Converter (Vector (IPair a))
forall a b. (a -> b) -> a -> b
$ \ (Text
k, Value
v) -> do
            case Parser Int -> Bytes -> Either ParseError Int
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' Parser Int
forall a. (Integral a, Bounded a) => Parser a
P.int (Text -> Bytes
T.getUTF8Bytes Text
k) of
                Right Int
k' -> do
                    a
v' <- Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
k
                    IPair a -> Converter (IPair a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a -> IPair a
forall a. Int -> a -> IPair a
V.IPair Int
k' a
v')
                Either ParseError Int
_ -> Text -> Converter (IPair a)
forall a. Text -> Converter a
fail' (Text
"converting Z.Data.Vector.FlatIntMap.FlatIntMap failed, unexpected key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k))
    {-# INLINE toValue #-}
    toValue :: FlatIntMap a -> Value
toValue = Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> (FlatIntMap a -> Vector (Text, Value)) -> FlatIntMap a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IPair a -> (Text, Value))
-> Vector (IPair a) -> Vector (Text, Value)
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map' IPair a -> (Text, Value)
forall a. JSON a => IPair a -> (Text, Value)
toKV (Vector (IPair a) -> Vector (Text, Value))
-> (FlatIntMap a -> Vector (IPair a))
-> FlatIntMap a
-> Vector (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatIntMap a -> Vector (IPair a)
forall v. FlatIntMap v -> Vector (IPair v)
FIM.sortedKeyValues
      where toKV :: IPair a -> (Text, Value)
toKV (V.IPair Int
i a
x) = let !k :: Text
k = Int -> Text
forall a. Print a => a -> Text
T.toText Int
i
                                     !v :: Value
v = a -> Value
forall a. JSON a => a -> Value
toValue a
x
                                 in (Text
k, Value
v)
    {-# INLINE encodeJSON #-}
    encodeJSON :: FlatIntMap a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.curly (Builder () -> Builder ())
-> (FlatIntMap a -> Builder ()) -> FlatIntMap a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder ()
-> (IPair a -> Builder ()) -> Vector (IPair a) -> Builder ()
forall (v :: * -> *) a.
Vec v a =>
Builder () -> (a -> Builder ()) -> v a -> Builder ()
B.intercalateVec Builder ()
B.comma (\ (V.IPair Int
i a
x) -> do
        Builder () -> Builder ()
B.quotes (Int -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int Int
i)
        Builder ()
B.colon
        a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON a
x) (Vector (IPair a) -> Builder ())
-> (FlatIntMap a -> Vector (IPair a)) -> FlatIntMap a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatIntMap a -> Vector (IPair a)
forall v. FlatIntMap v -> Vector (IPair v)
FIM.sortedKeyValues

instance JSON a => JSON (IM.IntMap a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (IntMap a)
fromValue = Text
-> (Vector (Text, Value) -> Converter (IntMap a))
-> Value
-> Converter (IntMap a)
forall a.
Text
-> (Vector (Text, Value) -> Converter a) -> Value -> Converter a
withKeyValues Text
"Data.IntMap.IntMap" ((Vector (Text, Value) -> Converter (IntMap a))
 -> Value -> Converter (IntMap a))
-> (Vector (Text, Value) -> Converter (IntMap a))
-> Value
-> Converter (IntMap a)
forall a b. (a -> b) -> a -> b
$ \ Vector (Text, Value)
kvs ->
        [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, a)] -> IntMap a)
-> Converter [(Int, a)] -> Converter (IntMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Text, Value)]
-> ((Text, Value) -> Converter (Int, a)) -> Converter [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Text, Value)
kvs) (((Text, Value) -> Converter (Int, a)) -> Converter [(Int, a)])
-> ((Text, Value) -> Converter (Int, a)) -> Converter [(Int, a)]
forall a b. (a -> b) -> a -> b
$ \ (Text
k, Value
v) -> do
            case Parser Int -> Bytes -> Either ParseError Int
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' Parser Int
forall a. (Integral a, Bounded a) => Parser a
P.int (Text -> Bytes
T.getUTF8Bytes Text
k) of
                Right Int
k' -> do
                    !a
v' <- Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key Text
k
                    (Int, a) -> Converter (Int, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
k', a
v')
                Either ParseError Int
_ -> Text -> Converter (Int, a)
forall a. Text -> Converter a
fail' (Text
"converting Data.IntMap.IntMap failed, unexpected key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k))
    {-# INLINE toValue #-}
    toValue :: IntMap a -> Value
toValue = Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> (IntMap a -> Vector (Text, Value)) -> IntMap a -> 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)] -> Vector (Text, Value))
-> (IntMap a -> [(Text, Value)])
-> IntMap a
-> Vector (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> (Text, Value)) -> [(Int, a)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> (Text, Value)
forall a a. (JSON a, Print a) => (a, a) -> (Text, Value)
toKV ([(Int, a)] -> [(Text, Value)])
-> (IntMap a -> [(Int, a)]) -> IntMap a -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IM.toList
      where toKV :: (a, a) -> (Text, Value)
toKV (a
i, a
x) = let !k :: Text
k = a -> Text
forall a. Print a => a -> Text
T.toText a
i
                              !v :: Value
v = a -> Value
forall a. JSON a => a -> Value
toValue a
x
                          in (Text
k, Value
v)
    {-# INLINE encodeJSON #-}
    encodeJSON :: IntMap a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.curly (Builder () -> Builder ())
-> (IntMap a -> Builder ()) -> IntMap a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> ((Int, a) -> Builder ()) -> [(Int, a)] -> Builder ()
forall a. Builder () -> (a -> Builder ()) -> [a] -> Builder ()
B.intercalateList Builder ()
B.comma (\ (Int
i, a
x) -> do
        Builder () -> Builder ()
B.quotes (Int -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int Int
i)
        Builder ()
B.colon
        a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON a
x) ([(Int, a)] -> Builder ())
-> (IntMap a -> [(Int, a)]) -> IntMap a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IM.toList

instance JSON FIS.FlatIntSet where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter FlatIntSet
fromValue = Text
-> (Vector Value -> Converter FlatIntSet)
-> Value
-> Converter FlatIntSet
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Vector.FlatIntSet.FlatIntSet" ((Vector Value -> Converter FlatIntSet)
 -> Value -> Converter FlatIntSet)
-> (Vector Value -> Converter FlatIntSet)
-> Value
-> Converter FlatIntSet
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        Int -> [Int] -> FlatIntSet
FIS.packRN (Vector Value -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Vector Value
vs) ([Int] -> FlatIntSet) -> Converter [Int] -> Converter FlatIntSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Value -> Converter Int)
-> [Int] -> [Value] -> Converter [Int]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter Int
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter Int -> PathElement -> Converter Int
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
    {-# INLINE toValue #-}
    toValue :: FlatIntSet -> Value
toValue = PrimVector Int -> Value
forall a. JSON a => a -> Value
toValue (PrimVector Int -> Value)
-> (FlatIntSet -> PrimVector Int) -> FlatIntSet -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatIntSet -> PrimVector Int
FIS.sortedValues
    {-# INLINE encodeJSON #-}
    encodeJSON :: FlatIntSet -> Builder ()
encodeJSON = PrimVector Int -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON (PrimVector Int -> Builder ())
-> (FlatIntSet -> PrimVector Int) -> FlatIntSet -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatIntSet -> PrimVector Int
FIS.sortedValues

instance JSON IS.IntSet where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter IntSet
fromValue = Text
-> (Vector Value -> Converter IntSet) -> Value -> Converter IntSet
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Data.IntSet.IntSet" ((Vector Value -> Converter IntSet) -> Value -> Converter IntSet)
-> (Vector Value -> Converter IntSet) -> Value -> Converter IntSet
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        [Int] -> IntSet
IS.fromList ([Int] -> IntSet) -> Converter [Int] -> Converter IntSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Value -> Converter Int)
-> [Int] -> [Value] -> Converter [Int]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter Int
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter Int -> PathElement -> Converter Int
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
    {-# INLINE toValue #-}
    toValue :: IntSet -> Value
toValue = [Int] -> Value
forall a. JSON a => a -> Value
toValue ([Int] -> Value) -> (IntSet -> [Int]) -> IntSet -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList
    {-# INLINE encodeJSON #-}
    encodeJSON :: IntSet -> Builder ()
encodeJSON = [Int] -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON ([Int] -> Builder ()) -> (IntSet -> [Int]) -> IntSet -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList

instance (Ord a, JSON a) => JSON (Set.Set a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Set a)
fromValue = Text
-> (Vector Value -> Converter (Set a))
-> Value
-> Converter (Set a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Data.Set.Set" ((Vector Value -> Converter (Set a)) -> Value -> Converter (Set a))
-> (Vector Value -> Converter (Set a))
-> Value
-> Converter (Set a)
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> Converter [a] -> Converter (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Value -> Converter a) -> [Int] -> [Value] -> Converter [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
    {-# INLINE toValue #-}
    toValue :: Set a -> Value
toValue = [a] -> Value
forall a. JSON a => a -> Value
toValue ([a] -> Value) -> (Set a -> [a]) -> Set a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList
    {-# INLINE encodeJSON #-}
    encodeJSON :: Set a -> Builder ()
encodeJSON = [a] -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON ([a] -> Builder ()) -> (Set a -> [a]) -> Set a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList

instance JSON a => JSON (Seq.Seq a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Seq a)
fromValue = Text
-> (Vector Value -> Converter (Seq a))
-> Value
-> Converter (Seq a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Data.Seq.Seq" ((Vector Value -> Converter (Seq a)) -> Value -> Converter (Seq a))
-> (Vector Value -> Converter (Seq a))
-> Value
-> Converter (Seq a)
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> Seq a) -> Converter [a] -> Converter (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Value -> Converter a) -> [Int] -> [Value] -> Converter [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
    {-# INLINE toValue #-}
    toValue :: Seq a -> Value
toValue = [a] -> Value
forall a. JSON a => a -> Value
toValue ([a] -> Value) -> (Seq a -> [a]) -> Seq a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList
    {-# INLINE encodeJSON #-}
    encodeJSON :: Seq a -> Builder ()
encodeJSON = [a] -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON ([a] -> Builder ()) -> (Seq a -> [a]) -> Seq a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList

instance JSON a => JSON (Tree.Tree a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Tree a)
fromValue = Text
-> (FlatMap Text Value -> Converter (Tree a))
-> Value
-> Converter (Tree a)
forall a.
Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"Data.Tree" ((FlatMap Text Value -> Converter (Tree a))
 -> Value -> Converter (Tree a))
-> (FlatMap Text Value -> Converter (Tree a))
-> Value
-> Converter (Tree a)
forall a b. (a -> b) -> a -> b
$ \FlatMap Text Value
obj -> do
        !a
n <- FlatMap Text Value
obj FlatMap Text Value -> Text -> Converter a
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"rootLabel"
        !Forest a
d <- FlatMap Text Value
obj FlatMap Text Value -> Text -> Converter (Forest a)
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"subForest"
        Tree a -> Converter (Tree a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Forest a -> Tree a
forall a. a -> Forest a -> Tree a
Tree.Node a
n Forest a
d)
    {-# INLINE toValue #-}
    toValue :: Tree a -> Value
toValue Tree a
x = [(Text, Value)] -> Value
object [ Text
"rootLabel" Text -> a -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= (Tree a -> a
forall a. Tree a -> a
Tree.rootLabel Tree a
x) , Text
"subForest" Text -> Forest a -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= (Tree a -> Forest a
forall a. Tree a -> Forest a
Tree.subForest Tree a
x) ]
    {-# INLINE encodeJSON #-}
    encodeJSON :: Tree a -> Builder ()
encodeJSON Tree a
x = KVItem -> Builder ()
object' ( Text
"rootLabel" Text -> a -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! (Tree a -> a
forall a. Tree a -> a
Tree.rootLabel Tree a
x) KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"subForest" Text -> Forest a -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! (Tree a -> Forest a
forall a. Tree a -> Forest a
Tree.subForest Tree a
x) )

instance JSON a => JSON (A.Array a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Array a)
fromValue = Text
-> (Vector Value -> Converter (Array a))
-> Value
-> Converter (Array a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Array.Array"
        ((Int -> Value -> Converter a)
-> Vector Value -> Converter (Array a)
forall (v :: * -> *) a (u :: * -> *) b (f :: * -> *).
(Vec v a, Vec u b, Applicative f) =>
(Int -> a -> f b) -> v a -> f (u b)
V.traverseWithIndex ((Int -> Value -> Converter a)
 -> Vector Value -> Converter (Array a))
-> (Int -> Value -> Converter a)
-> Vector Value
-> Converter (Array a)
forall a b. (a -> b) -> a -> b
$ \ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k)
    {-# INLINE toValue #-}
    toValue :: Array a -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value)
-> (Array a -> Vector Value) -> Array a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> Array a -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: Array a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (Array a -> Builder ()) -> Array a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array a -> Builder ()
forall a (v :: * -> *). (JSON a, Vec v a) => v a -> Builder ()
commaSepVec

instance JSON a => JSON (A.SmallArray a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (SmallArray a)
fromValue = Text
-> (Vector Value -> Converter (SmallArray a))
-> Value
-> Converter (SmallArray a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Array.SmallArray"
        ((Int -> Value -> Converter a)
-> Vector Value -> Converter (SmallArray a)
forall (v :: * -> *) a (u :: * -> *) b (f :: * -> *).
(Vec v a, Vec u b, Applicative f) =>
(Int -> a -> f b) -> v a -> f (u b)
V.traverseWithIndex ((Int -> Value -> Converter a)
 -> Vector Value -> Converter (SmallArray a))
-> (Int -> Value -> Converter a)
-> Vector Value
-> Converter (SmallArray a)
forall a b. (a -> b) -> a -> b
$ \ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k)
    {-# INLINE toValue #-}
    toValue :: SmallArray a -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value)
-> (SmallArray a -> Vector Value) -> SmallArray a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> SmallArray a -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: SmallArray a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (SmallArray a -> Builder ()) -> SmallArray a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SmallArray a -> Builder ()
forall a (v :: * -> *). (JSON a, Vec v a) => v a -> Builder ()
commaSepVec

instance (Prim a, JSON a) => JSON (A.PrimArray a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (PrimArray a)
fromValue = Text
-> (Vector Value -> Converter (PrimArray a))
-> Value
-> Converter (PrimArray a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Array.PrimArray"
        ((Int -> Value -> Converter a)
-> Vector Value -> Converter (PrimArray a)
forall (v :: * -> *) a (u :: * -> *) b (f :: * -> *).
(Vec v a, Vec u b, Applicative f) =>
(Int -> a -> f b) -> v a -> f (u b)
V.traverseWithIndex ((Int -> Value -> Converter a)
 -> Vector Value -> Converter (PrimArray a))
-> (Int -> Value -> Converter a)
-> Vector Value
-> Converter (PrimArray a)
forall a b. (a -> b) -> a -> b
$ \ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k)
    {-# INLINE toValue #-}
    toValue :: PrimArray a -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value)
-> (PrimArray a -> Vector Value) -> PrimArray a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> PrimArray a -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: PrimArray a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (PrimArray a -> Builder ()) -> PrimArray a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimArray a -> Builder ()
forall a (v :: * -> *). (JSON a, Vec v a) => v a -> Builder ()
commaSepVec

instance JSON A.ByteArray where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter ByteArray
fromValue Value
value = do
        (A.PrimArray ByteArray#
ba# :: A.PrimArray Word8) <-
                Text
-> (Vector Value -> Converter (PrimArray Word8))
-> Value
-> Converter (PrimArray Word8)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Data.Primitive.ByteArray"
                    ((Int -> Value -> Converter Word8)
-> Vector Value -> Converter (PrimArray Word8)
forall (v :: * -> *) a (u :: * -> *) b (f :: * -> *).
(Vec v a, Vec u b, Applicative f) =>
(Int -> a -> f b) -> v a -> f (u b)
V.traverseWithIndex ((Int -> Value -> Converter Word8)
 -> Vector Value -> Converter (PrimArray Word8))
-> (Int -> Value -> Converter Word8)
-> Vector Value
-> Converter (PrimArray Word8)
forall a b. (a -> b) -> a -> b
$ \ Int
k Value
v -> Value -> Converter Word8
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter Word8 -> PathElement -> Converter Word8
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) Value
value
        ByteArray -> Converter ByteArray
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ByteArray
A.ByteArray ByteArray#
ba#)
    {-# INLINE toValue #-}
    toValue :: ByteArray -> Value
toValue (A.ByteArray ByteArray#
ba#) =
        Vector Value -> Value
Array ((Word8 -> Value) -> PrimArray Word8 -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map Word8 -> Value
forall a. JSON a => a -> Value
toValue (ByteArray# -> PrimArray Word8
forall a. ByteArray# -> PrimArray a
A.PrimArray ByteArray#
ba# :: A.PrimArray Word8))
    {-# INLINE encodeJSON #-}
    encodeJSON :: ByteArray -> Builder ()
encodeJSON (A.ByteArray ByteArray#
ba#) =
        Builder () -> Builder ()
B.square (PrimArray Word8 -> Builder ()
forall a (v :: * -> *). (JSON a, Vec v a) => v a -> Builder ()
commaSepVec (ByteArray# -> PrimArray Word8
forall a. ByteArray# -> PrimArray a
A.PrimArray ByteArray#
ba# :: A.PrimArray Word8))

instance (A.PrimUnlifted a, JSON a) => JSON (A.UnliftedArray a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (UnliftedArray a)
fromValue = Text
-> (Vector Value -> Converter (UnliftedArray a))
-> Value
-> Converter (UnliftedArray a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Array.UnliftedArray"
        ((Int -> Value -> Converter a)
-> Vector Value -> Converter (UnliftedArray a)
forall (v :: * -> *) a (u :: * -> *) b (f :: * -> *).
(Vec v a, Vec u b, Applicative f) =>
(Int -> a -> f b) -> v a -> f (u b)
V.traverseWithIndex ((Int -> Value -> Converter a)
 -> Vector Value -> Converter (UnliftedArray a))
-> (Int -> Value -> Converter a)
-> Vector Value
-> Converter (UnliftedArray a)
forall a b. (a -> b) -> a -> b
$ \ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k)
    {-# INLINE toValue #-}
    toValue :: UnliftedArray a -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value)
-> (UnliftedArray a -> Vector Value) -> UnliftedArray a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> UnliftedArray a -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: UnliftedArray a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (UnliftedArray a -> Builder ()) -> UnliftedArray a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftedArray a -> Builder ()
forall a (v :: * -> *). (JSON a, Vec v a) => v a -> Builder ()
commaSepVec

instance JSON a => JSON (V.Vector a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Vector a)
fromValue = Text
-> (Vector Value -> Converter (Vector a))
-> Value
-> Converter (Vector a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Vector.Vector"
        ((Int -> Value -> Converter a)
-> Vector Value -> Converter (Vector a)
forall (v :: * -> *) a (u :: * -> *) b (f :: * -> *).
(Vec v a, Vec u b, Applicative f) =>
(Int -> a -> f b) -> v a -> f (u b)
V.traverseWithIndex ((Int -> Value -> Converter a)
 -> Vector Value -> Converter (Vector a))
-> (Int -> Value -> Converter a)
-> Vector Value
-> Converter (Vector a)
forall a b. (a -> b) -> a -> b
$ \ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k)
    {-# INLINE toValue #-}
    toValue :: Vector a -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value)
-> (Vector a -> Vector Value) -> Vector a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> Vector a -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: Vector a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (Vector a -> Builder ()) -> Vector a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> Builder ()
forall a (v :: * -> *). (JSON a, Vec v a) => v a -> Builder ()
commaSepVec

instance (Prim a, JSON a) => JSON (V.PrimVector a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (PrimVector a)
fromValue = Text
-> (Vector Value -> Converter (PrimVector a))
-> Value
-> Converter (PrimVector a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Vector.PrimVector"
        ((Int -> Value -> Converter a)
-> Vector Value -> Converter (PrimVector a)
forall (v :: * -> *) a (u :: * -> *) b (f :: * -> *).
(Vec v a, Vec u b, Applicative f) =>
(Int -> a -> f b) -> v a -> f (u b)
V.traverseWithIndex ((Int -> Value -> Converter a)
 -> Vector Value -> Converter (PrimVector a))
-> (Int -> Value -> Converter a)
-> Vector Value
-> Converter (PrimVector a)
forall a b. (a -> b) -> a -> b
$ \ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k)
    {-# INLINE toValue #-}
    toValue :: PrimVector a -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value)
-> (PrimVector a -> Vector Value) -> PrimVector a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> PrimVector a -> Vector Value
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: PrimVector a -> Builder ()
encodeJSON = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> (PrimVector a -> Builder ()) -> PrimVector a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimVector a -> Builder ()
forall a (v :: * -> *). (JSON a, Vec v a) => v a -> Builder ()
commaSepVec

instance (Eq a, Hashable a, JSON a) => JSON (HS.HashSet a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (HashSet a)
fromValue = Text
-> (Vector Value -> Converter (HashSet a))
-> Value
-> Converter (HashSet a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"Z.Data.Vector.FlatSet.FlatSet" ((Vector Value -> Converter (HashSet a))
 -> Value -> Converter (HashSet a))
-> (Vector Value -> Converter (HashSet a))
-> Value
-> Converter (HashSet a)
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        [a] -> HashSet a
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([a] -> HashSet a) -> Converter [a] -> Converter (HashSet a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ((Int -> Value -> Converter a) -> [Int] -> [Value] -> Converter [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs))
    {-# INLINE toValue #-}
    toValue :: HashSet a -> Value
toValue = [a] -> Value
forall a. JSON a => a -> Value
toValue ([a] -> Value) -> (HashSet a -> [a]) -> HashSet a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> [a]
forall a. HashSet a -> [a]
HS.toList
    {-# INLINE encodeJSON #-}
    encodeJSON :: HashSet a -> Builder ()
encodeJSON = [a] -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON ([a] -> Builder ())
-> (HashSet a -> [a]) -> HashSet a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> [a]
forall a. HashSet a -> [a]
HS.toList

instance JSON a => JSON [a] where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter [a]
fromValue = Text -> (Vector Value -> Converter [a]) -> Value -> Converter [a]
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"[a]" ((Vector Value -> Converter [a]) -> Value -> Converter [a])
-> (Vector Value -> Converter [a]) -> Value -> Converter [a]
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        (Int -> Value -> Converter a) -> [Int] -> [Value] -> Converter [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
    {-# INLINE toValue #-}
    toValue :: [a] -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value) -> ([a] -> Vector Value) -> [a] -> 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] -> Vector Value)
-> ([a] -> [Value]) -> [a] -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. JSON a => a -> Value
toValue
    {-# INLINE encodeJSON #-}
    encodeJSON :: [a] -> Builder ()
encodeJSON = Builder () -> Builder ()
B.square (Builder () -> Builder ())
-> ([a] -> Builder ()) -> [a] -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Builder ()
forall a. JSON a => [a] -> Builder ()
commaSepList

instance JSON a => JSON (NonEmpty a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (NonEmpty a)
fromValue = Text
-> (Vector Value -> Converter (NonEmpty a))
-> Value
-> Converter (NonEmpty a)
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"NonEmpty" ((Vector Value -> Converter (NonEmpty a))
 -> Value -> Converter (NonEmpty a))
-> (Vector Value -> Converter (NonEmpty a))
-> Value
-> Converter (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs -> do
        [a]
l <- (Int -> Value -> Converter a) -> [Int] -> [Value] -> Converter [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
        case [a]
l of (a
x:[a]
xs) -> NonEmpty a -> Converter (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
                  [a]
_      -> Text -> Converter (NonEmpty a)
forall a. Text -> Converter a
fail' Text
"unexpected empty array"
    {-# INLINE toValue #-}
    toValue :: NonEmpty a -> Value
toValue = [a] -> Value
forall a. JSON a => a -> Value
toValue ([a] -> Value) -> (NonEmpty a -> [a]) -> NonEmpty a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.toList
    {-# INLINE encodeJSON #-}
    encodeJSON :: NonEmpty a -> Builder ()
encodeJSON = [a] -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON ([a] -> Builder ())
-> (NonEmpty a -> [a]) -> NonEmpty a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.toList

instance JSON Bool where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Bool
fromValue = Text -> (Bool -> Converter Bool) -> Value -> Converter Bool
forall a. Text -> (Bool -> Converter a) -> Value -> Converter a
withBool Text
"Bool" Bool -> Converter Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Bool -> Value
toValue = Bool -> Value
Bool;
    {-# INLINE encodeJSON #-}; encodeJSON :: Bool -> Builder ()
encodeJSON Bool
True = Builder ()
"true"; encodeJSON Bool
_ = Builder ()
"false";

instance JSON Char where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Char
fromValue = Text -> (Text -> Converter Char) -> Value -> Converter Char
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"Char" ((Text -> Converter Char) -> Value -> Converter Char)
-> (Text -> Converter Char) -> Value -> Converter Char
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        if (Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
        then Char -> Converter Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Char
T.head Text
t)
        else Text -> Converter Char
forall a. Text -> Converter a
fail' (ParseError -> Text
T.concat [Text
"converting Char failed, expected a string of length 1"])
    {-# INLINE toValue #-}
    toValue :: Char -> Value
toValue = Text -> Value
String (Text -> Value) -> (Char -> Text) -> Char -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton
-- @
--    \'\\b\':  \"\\b\"
--    \'\\f\':  \"\\f\"
--    \'\\n\':  \"\\n\"
--    \'\\r\':  \"\\r\"
--    \'\\t\':  \"\\t\"
--    \'\"\':  \"\\\"\"
--    \'\\\':  \"\\\\\"
--    other chars <= 0x1F: "\\u00XX"
-- @
    {-# INLINE encodeJSON #-}
    encodeJSON :: Char -> Builder ()
encodeJSON Char
'\b' = Builder ()
"\"\\b\""
    encodeJSON Char
'\f' = Builder ()
"\"\\f\""
    encodeJSON Char
'\n' = Builder ()
"\"\\n\""
    encodeJSON Char
'\r' = Builder ()
"\"\\r\""
    encodeJSON Char
'\t' = Builder ()
"\"\\t\""
    encodeJSON Char
'\"' = Builder ()
"\"\\\"\""
    encodeJSON Char
'\\' = Builder ()
"\"\\\\\""
    encodeJSON Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\US' = Builder ()
"\"\\u00" Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Builder ()
forall a. (FiniteBits a, Integral a) => a -> Builder ()
B.hex (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) :: Word8) Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Builder ()
B.char8 Char
'\"'
                 | Bool
otherwise  = Builder () -> Builder ()
B.quotes (Char -> Builder ()
B.charUTF8 Char
c)


instance JSON Double where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Double
fromValue = Text -> (Double -> Converter Double) -> Value -> Converter Double
forall a r.
RealFloat a =>
Text -> (a -> Converter r) -> Value -> Converter r
withRealFloat Text
"Double" Double -> Converter Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Double -> Value
toValue = Scientific -> Value
Number (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scientific
P.doubleToScientific;
    {-# INLINE encodeJSON #-}; encodeJSON :: Double -> Builder ()
encodeJSON = Double -> Builder ()
B.double;
instance JSON Float  where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Float
fromValue = Text -> (Float -> Converter Float) -> Value -> Converter Float
forall a r.
RealFloat a =>
Text -> (a -> Converter r) -> Value -> Converter r
withRealFloat Text
"Float" Float -> Converter Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Float -> Value
toValue = Scientific -> Value
Number (Scientific -> Value) -> (Float -> Scientific) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Scientific
P.floatToScientific;
    {-# INLINE encodeJSON #-}; encodeJSON :: Float -> Builder ()
encodeJSON = Float -> Builder ()
B.float;

#define INT_JSON_INSTANCE(typ) \
    instance JSON typ where \
        {-# INLINE fromValue #-}; fromValue = withBoundedIntegral "/**/typ/**/" pure; \
        {-# INLINE toValue #-}; toValue = Number . fromIntegral; \
        {-# INLINE encodeJSON #-}; encodeJSON = B.int;

INT_JSON_INSTANCE(Int   )
INT_JSON_INSTANCE(Int8  )
INT_JSON_INSTANCE(Int16 )
INT_JSON_INSTANCE(Int32 )
INT_JSON_INSTANCE(Int64 )
INT_JSON_INSTANCE(Word  )
INT_JSON_INSTANCE(Word8 )
INT_JSON_INSTANCE(Word16)
INT_JSON_INSTANCE(Word32)
INT_JSON_INSTANCE(Word64)

-- | This instance includes a bounds check to prevent maliciously large inputs to fill up the memory of the target system. You can newtype 'Integer' and provide your own instance using 'withScientific' if you want to allow larger inputs.
instance JSON Integer where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Integer
fromValue = Text
-> (Scientific -> Converter Integer) -> Value -> Converter Integer
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
"Integer" ((Scientific -> Converter Integer) -> Value -> Converter Integer)
-> (Scientific -> Converter Integer) -> Value -> Converter Integer
forall a b. (a -> b) -> a -> b
$ \ Scientific
n ->
        case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
n :: Either Double Integer of
            Right Integer
x -> Integer -> Converter Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
            Left Double
_  -> Text -> Converter Integer
forall a. Text -> Converter a
fail' (Text -> Converter Integer)
-> (Builder () -> Text) -> Builder () -> Converter Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter Integer)
-> Builder () -> Converter Integer
forall a b. (a -> b) -> a -> b
$ do
                Builder ()
"converting Integer failed, unexpected floating number "
                Scientific -> Builder ()
T.scientific Scientific
n
    {-# INLINE toValue #-}
    toValue :: Integer -> Value
toValue = Scientific -> Value
Number (Scientific -> Value)
-> (Integer -> Scientific) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    {-# INLINE encodeJSON #-}
    encodeJSON :: Integer -> Builder ()
encodeJSON = Integer -> Builder ()
B.integer

-- | This instance includes a bounds check to prevent maliciously large inputs to fill up the memory of the target system. You can newtype 'Natural' and provide your own instance using 'withScientific' if you want to allow larger inputs.
instance JSON Natural where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Natural
fromValue = Text
-> (Scientific -> Converter Natural) -> Value -> Converter Natural
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
"Natural" ((Scientific -> Converter Natural) -> Value -> Converter Natural)
-> (Scientific -> Converter Natural) -> Value -> Converter Natural
forall a b. (a -> b) -> a -> b
$ \ Scientific
n ->
        if Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
< Scientific
0
        then Text -> Converter Natural
forall a. Text -> Converter a
fail' (Text -> Converter Natural)
-> (Builder () -> Text) -> Builder () -> Converter Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter Natural)
-> Builder () -> Converter Natural
forall a b. (a -> b) -> a -> b
$ do
                Builder ()
"converting Natural failed, unexpected negative number "
                Scientific -> Builder ()
T.scientific Scientific
n
        else case Scientific -> Either Double Natural
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
n :: Either Double Natural of
            Right Natural
x -> Natural -> Converter Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
x
            Left Double
_  -> Text -> Converter Natural
forall a. Text -> Converter a
fail' (Text -> Converter Natural)
-> (Builder () -> Text) -> Builder () -> Converter Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter Natural)
-> Builder () -> Converter Natural
forall a b. (a -> b) -> a -> b
$ do
                Builder ()
"converting Natural failed, unexpected floating number "
                Scientific -> Builder ()
T.scientific Scientific
n
    {-# INLINE toValue #-}
    toValue :: Natural -> Value
toValue = Scientific -> Value
Number (Scientific -> Value)
-> (Natural -> Scientific) -> Natural -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    {-# INLINE encodeJSON #-}
    encodeJSON :: Natural -> Builder ()
encodeJSON = Integer -> Builder ()
B.integer (Integer -> Builder ())
-> (Natural -> Integer) -> Natural -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance JSON Ordering where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Ordering
fromValue = Text -> (Text -> Converter Ordering) -> Value -> Converter Ordering
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"Ordering" ((Text -> Converter Ordering) -> Value -> Converter Ordering)
-> (Text -> Converter Ordering) -> Value -> Converter Ordering
forall a b. (a -> b) -> a -> b
$ \ Text
s ->
        case Text
s of
            Text
"LT" -> Ordering -> Converter Ordering
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
LT
            Text
"EQ" -> Ordering -> Converter Ordering
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
EQ
            Text
"GT" -> Ordering -> Converter Ordering
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
GT
            Text
_ -> Text -> Converter Ordering
forall a. Text -> Converter a
fail' (Text -> Converter Ordering)
-> (ParseError -> Text) -> ParseError -> Converter Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> Text
T.concat (ParseError -> Converter Ordering)
-> ParseError -> Converter Ordering
forall a b. (a -> b) -> a -> b
$ [Text
"converting Ordering failed, unexpected ",
                                        Text
s, Text
" expected \"LT\", \"EQ\", or \"GT\""]
    {-# INLINE toValue #-}
    toValue :: Ordering -> Value
toValue Ordering
LT = Text -> Value
String Text
"LT"
    toValue Ordering
EQ = Text -> Value
String Text
"EQ"
    toValue Ordering
GT = Text -> Value
String Text
"GT"
    {-# INLINE encodeJSON #-}
    encodeJSON :: Ordering -> Builder ()
encodeJSON Ordering
LT = Builder ()
"\"LT\""
    encodeJSON Ordering
EQ = Builder ()
"\"EQ\""
    encodeJSON Ordering
GT = Builder ()
"\"GT\""

instance JSON () where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter ()
fromValue = Text -> (Vector Value -> Converter ()) -> Value -> Converter ()
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"()" ((Vector Value -> Converter ()) -> Value -> Converter ())
-> (Vector Value -> Converter ()) -> Value -> Converter ()
forall a b. (a -> b) -> a -> b
$ \ Vector Value
v ->
        if Vector Value -> Bool
forall (v :: * -> *) a. Vec v a => v a -> Bool
V.null Vector Value
v
        then () -> Converter ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else Text -> Converter ()
forall a. Text -> Converter a
fail' Text
"converting () failed, expected an empty array"
    {-# INLINE toValue #-}
    toValue :: () -> Value
toValue () = Vector Value -> Value
Array Vector Value
forall (v :: * -> *) a. Vec v a => v a
V.empty
    {-# INLINE encodeJSON #-}
    encodeJSON :: () -> Builder ()
encodeJSON () = Builder ()
"[]"

instance JSON ExitCode where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter ExitCode
fromValue (String Text
"ExitSuccess") = ExitCode -> Converter ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
    fromValue (Number Scientific
x) =
        case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
x of
            Just Int
i -> ExitCode -> Converter ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
i)
            Maybe Int
_      -> Text -> Converter ExitCode
forall a. Text -> Converter a
fail' (Text -> Converter ExitCode)
-> (Builder () -> Text) -> Builder () -> Converter ExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter ExitCode)
-> Builder () -> Converter ExitCode
forall a b. (a -> b) -> a -> b
$ do
                Builder ()
"converting ExitCode failed, value is either floating or will cause over or underflow: "
                Scientific -> Builder ()
T.scientific Scientific
x
    fromValue Value
_ =  Text -> Converter ExitCode
forall a. Text -> Converter a
fail' Text
"converting ExitCode failed, expected a string or number"

    {-# INLINE toValue #-}
    toValue :: ExitCode -> Value
toValue ExitCode
ExitSuccess     = Text -> Value
String Text
"ExitSuccess"
    toValue (ExitFailure Int
n) = Scientific -> Value
Number (Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

    {-# INLINE encodeJSON #-}
    encodeJSON :: ExitCode -> Builder ()
encodeJSON ExitCode
ExitSuccess     = Builder ()
"\"ExitSuccess\""
    encodeJSON (ExitFailure Int
n) = Int -> Builder ()
forall a. (Integral a, Bounded a) => a -> Builder ()
B.int Int
n

-- | Only round trip 'versionBranch' as JSON array.
instance JSON Version where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Version
fromValue Value
v = [Int] -> Version
makeVersion ([Int] -> Version) -> Converter [Int] -> Converter Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Converter [Int]
forall a. JSON a => Value -> Converter a
fromValue Value
v
    {-# INLINE toValue #-}
    toValue :: Version -> Value
toValue = [Int] -> Value
forall a. JSON a => a -> Value
toValue ([Int] -> Value) -> (Version -> [Int]) -> Version -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionBranch
    {-# INLINE encodeJSON #-}
    encodeJSON :: Version -> Builder ()
encodeJSON = [Int] -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON ([Int] -> Builder ())
-> (Version -> [Int]) -> Version -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionBranch

instance JSON a => JSON (Maybe a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Maybe a)
fromValue Value
Null = Maybe a -> Converter (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    fromValue Value
v    = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Converter a -> Converter (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Converter a
forall a. JSON a => Value -> Converter a
fromValue Value
v
    {-# INLINE toValue #-}
    toValue :: Maybe a -> Value
toValue Maybe a
Nothing  = Value
Null
    toValue (Just a
x) = a -> Value
forall a. JSON a => a -> Value
toValue a
x
    {-# INLINE encodeJSON #-}
    encodeJSON :: Maybe a -> Builder ()
encodeJSON Maybe a
Nothing  = Builder ()
"null"
    encodeJSON (Just a
x) = a -> Builder ()
forall a. JSON a => a -> Builder ()
encodeJSON a
x

-- | This instance includes a bounds check to prevent maliciously large inputs to fill up the memory of the target system. You can newtype Ratio and provide your own instance using 'withScientific' if you want to allow larger inputs.
instance (JSON a, Integral a) => JSON (Ratio a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Ratio a)
fromValue = Text
-> (FlatMap Text Value -> Converter (Ratio a))
-> Value
-> Converter (Ratio a)
forall a.
Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"Rational" ((FlatMap Text Value -> Converter (Ratio a))
 -> Value -> Converter (Ratio a))
-> (FlatMap Text Value -> Converter (Ratio a))
-> Value
-> Converter (Ratio a)
forall a b. (a -> b) -> a -> b
$ \FlatMap Text Value
obj -> do
        !a
n <- FlatMap Text Value
obj FlatMap Text Value -> Text -> Converter a
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"numerator"
        !a
d <- FlatMap Text Value
obj FlatMap Text Value -> Text -> Converter a
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"denominator"
        if a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
        then Text -> Converter (Ratio a)
forall a. Text -> Converter a
fail' Text
"Ratio denominator was 0"
        else Ratio a -> Converter (Ratio a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
d)
    {-# INLINE toValue #-}
    toValue :: Ratio a -> Value
toValue Ratio a
x = [(Text, Value)] -> Value
object [ Text
"numerator" Text -> a -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
x) , Text
"denominator" Text -> a -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
x) ]
    {-# INLINE encodeJSON #-}
    encodeJSON :: Ratio a -> Builder ()
encodeJSON Ratio a
x = KVItem -> Builder ()
object' ( Text
"numerator" Text -> a -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
x) KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"denominator" Text -> a -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
x) )

-- | This instance includes a bounds check to prevent maliciously large inputs to fill up the memory of the target system. You can newtype Fixed and provide your own instance using 'withScientific' if you want to allow larger inputs.
instance HasResolution a => JSON (Fixed a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Fixed a)
fromValue = Text
-> (Scientific -> Converter (Fixed a))
-> Value
-> Converter (Fixed a)
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
"Fixed" (Fixed a -> Converter (Fixed a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fixed a -> Converter (Fixed a))
-> (Scientific -> Fixed a) -> Scientific -> Converter (Fixed a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Fixed a
forall a b. (Real a, Fractional b) => a -> b
realToFrac)
    {-# INLINE toValue #-}
    toValue :: Fixed a -> Value
toValue = Scientific -> Value
Number (Scientific -> Value)
-> (Fixed a -> Scientific) -> Fixed a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixed a -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    {-# INLINE encodeJSON #-}
    encodeJSON :: Fixed a -> Builder ()
encodeJSON = Scientific -> Builder ()
JB.scientific (Scientific -> Builder ())
-> (Fixed a -> Scientific) -> Fixed a -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixed a -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac

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

-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance JSON UTCTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter UTCTime
fromValue = Text -> (Text -> Converter UTCTime) -> Value -> Converter UTCTime
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"UTCTime" ((Text -> Converter UTCTime) -> Value -> Converter UTCTime)
-> (Text -> Converter UTCTime) -> Value -> Converter UTCTime
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        case Parser UTCTime -> Bytes -> Either ParseError UTCTime
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser UTCTime
P.utcTime Parser UTCTime -> Parser () -> Parser UTCTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) (Text -> Bytes
T.getUTF8Bytes Text
t) of
            Left ParseError
err -> Text -> Converter UTCTime
forall a. Text -> Converter a
fail' (Text -> Converter UTCTime) -> Text -> Converter UTCTime
forall a b. (a -> b) -> a -> b
$ Text
"could not parse date as UTCTime: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall a. Print a => a -> Text
T.toText ParseError
err
            Right UTCTime
r  -> UTCTime -> Converter UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
r
    {-# INLINE toValue #-}
    toValue :: UTCTime -> Value
toValue UTCTime
t = Text -> Value
String (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (UTCTime -> Builder ()
B.utcTime UTCTime
t))
    {-# INLINE encodeJSON #-}
    encodeJSON :: UTCTime -> Builder ()
encodeJSON = Builder () -> Builder ()
B.quotes (Builder () -> Builder ())
-> (UTCTime -> Builder ()) -> UTCTime -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Builder ()
B.utcTime

-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance JSON ZonedTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter ZonedTime
fromValue = Text
-> (Text -> Converter ZonedTime) -> Value -> Converter ZonedTime
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"ZonedTime" ((Text -> Converter ZonedTime) -> Value -> Converter ZonedTime)
-> (Text -> Converter ZonedTime) -> Value -> Converter ZonedTime
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        case Parser ZonedTime -> Bytes -> Either ParseError ZonedTime
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser ZonedTime
P.zonedTime Parser ZonedTime -> Parser () -> Parser ZonedTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) (Text -> Bytes
T.getUTF8Bytes Text
t) of
            Left ParseError
err -> Text -> Converter ZonedTime
forall a. Text -> Converter a
fail' (Text -> Converter ZonedTime) -> Text -> Converter ZonedTime
forall a b. (a -> b) -> a -> b
$ Text
"could not parse date as ZonedTime: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall a. Print a => a -> Text
T.toText ParseError
err
            Right ZonedTime
r  -> ZonedTime -> Converter ZonedTime
forall (m :: * -> *) a. Monad m => a -> m a
return ZonedTime
r
    {-# INLINE toValue #-}
    toValue :: ZonedTime -> Value
toValue ZonedTime
t = Text -> Value
String (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (ZonedTime -> Builder ()
B.zonedTime ZonedTime
t))
    {-# INLINE encodeJSON #-}
    encodeJSON :: ZonedTime -> Builder ()
encodeJSON = Builder () -> Builder ()
B.quotes (Builder () -> Builder ())
-> (ZonedTime -> Builder ()) -> ZonedTime -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> Builder ()
B.zonedTime

-- | @YYYY-MM-DD@
instance JSON Day where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Day
fromValue = Text -> (Text -> Converter Day) -> Value -> Converter Day
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"Day" ((Text -> Converter Day) -> Value -> Converter Day)
-> (Text -> Converter Day) -> Value -> Converter Day
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        case Parser Day -> Bytes -> Either ParseError Day
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser Day
P.day Parser Day -> Parser () -> Parser Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) (Text -> Bytes
T.getUTF8Bytes Text
t) of
            Left ParseError
err -> Text -> Converter Day
forall a. Text -> Converter a
fail' (Text -> Converter Day) -> Text -> Converter Day
forall a b. (a -> b) -> a -> b
$ Text
"could not parse date as Day: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall a. Print a => a -> Text
T.toText ParseError
err
            Right Day
r  -> Day -> Converter Day
forall (m :: * -> *) a. Monad m => a -> m a
return Day
r
    {-# INLINE toValue #-}
    toValue :: Day -> Value
toValue Day
t = Text -> Value
String (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Day -> Builder ()
B.day Day
t))
    {-# INLINE encodeJSON #-}
    encodeJSON :: Day -> Builder ()
encodeJSON = Builder () -> Builder ()
B.quotes (Builder () -> Builder ())
-> (Day -> Builder ()) -> Day -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Builder ()
B.day


-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance JSON LocalTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter LocalTime
fromValue = Text
-> (Text -> Converter LocalTime) -> Value -> Converter LocalTime
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"LocalTime" ((Text -> Converter LocalTime) -> Value -> Converter LocalTime)
-> (Text -> Converter LocalTime) -> Value -> Converter LocalTime
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        case Parser LocalTime -> Bytes -> Either ParseError LocalTime
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser LocalTime
P.localTime Parser LocalTime -> Parser () -> Parser LocalTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) (Text -> Bytes
T.getUTF8Bytes Text
t) of
            Left ParseError
err -> Text -> Converter LocalTime
forall a. Text -> Converter a
fail' (Text -> Converter LocalTime) -> Text -> Converter LocalTime
forall a b. (a -> b) -> a -> b
$ Text
"could not parse date as LocalTime: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall a. Print a => a -> Text
T.toText ParseError
err
            Right LocalTime
r  -> LocalTime -> Converter LocalTime
forall (m :: * -> *) a. Monad m => a -> m a
return LocalTime
r
    {-# INLINE toValue #-}
    toValue :: LocalTime -> Value
toValue LocalTime
t = Text -> Value
String (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (LocalTime -> Builder ()
B.localTime LocalTime
t))
    {-# INLINE encodeJSON #-}
    encodeJSON :: LocalTime -> Builder ()
encodeJSON = Builder () -> Builder ()
B.quotes (Builder () -> Builder ())
-> (LocalTime -> Builder ()) -> LocalTime -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> Builder ()
B.localTime

-- | @HH:MM:SS.SSS@
instance JSON TimeOfDay where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter TimeOfDay
fromValue = Text
-> (Text -> Converter TimeOfDay) -> Value -> Converter TimeOfDay
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withText Text
"TimeOfDay" ((Text -> Converter TimeOfDay) -> Value -> Converter TimeOfDay)
-> (Text -> Converter TimeOfDay) -> Value -> Converter TimeOfDay
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        case Parser TimeOfDay -> Bytes -> Either ParseError TimeOfDay
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser TimeOfDay
P.timeOfDay Parser TimeOfDay -> Parser () -> Parser TimeOfDay
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) (Text -> Bytes
T.getUTF8Bytes Text
t) of
            Left ParseError
err -> Text -> Converter TimeOfDay
forall a. Text -> Converter a
fail' (Text -> Converter TimeOfDay) -> Text -> Converter TimeOfDay
forall a b. (a -> b) -> a -> b
$ Text
"could not parse time as TimeOfDay: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall a. Print a => a -> Text
T.toText ParseError
err
            Right TimeOfDay
r  -> TimeOfDay -> Converter TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return TimeOfDay
r
    {-# INLINE toValue #-}
    toValue :: TimeOfDay -> Value
toValue TimeOfDay
t = Text -> Value
String (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (TimeOfDay -> Builder ()
B.timeOfDay TimeOfDay
t))
    {-# INLINE encodeJSON #-}
    encodeJSON :: TimeOfDay -> Builder ()
encodeJSON = Builder () -> Builder ()
B.quotes (Builder () -> Builder ())
-> (TimeOfDay -> Builder ()) -> TimeOfDay -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeOfDay -> Builder ()
B.timeOfDay

-- | This instance includes a bounds check to prevent maliciously
-- large inputs to fill up the memory of the target system. You can
-- newtype 'NominalDiffTime' and provide your own instance using
-- 'withScientific' if you want to allow larger inputs.
instance JSON NominalDiffTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter NominalDiffTime
fromValue = Text
-> (Scientific -> Converter NominalDiffTime)
-> Value
-> Converter NominalDiffTime
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
"NominalDiffTime" ((Scientific -> Converter NominalDiffTime)
 -> Value -> Converter NominalDiffTime)
-> (Scientific -> Converter NominalDiffTime)
-> Value
-> Converter NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Converter NominalDiffTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NominalDiffTime -> Converter NominalDiffTime)
-> (Scientific -> NominalDiffTime)
-> Scientific
-> Converter NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    {-# INLINE toValue #-}
    toValue :: NominalDiffTime -> Value
toValue = Scientific -> Value
Number (Scientific -> Value)
-> (NominalDiffTime -> Scientific) -> NominalDiffTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    {-# INLINE encodeJSON #-}
    encodeJSON :: NominalDiffTime -> Builder ()
encodeJSON = Scientific -> Builder ()
JB.scientific (Scientific -> Builder ())
-> (NominalDiffTime -> Scientific) -> NominalDiffTime -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | This instance includes a bounds check to prevent maliciously
-- large inputs to fill up the memory of the target system. You can
-- newtype 'DiffTime' and provide your own instance using
-- 'withScientific' if you want to allow larger inputs.
instance JSON DiffTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter DiffTime
fromValue = Text
-> (Scientific -> Converter DiffTime)
-> Value
-> Converter DiffTime
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
"DiffTime" ((Scientific -> Converter DiffTime) -> Value -> Converter DiffTime)
-> (Scientific -> Converter DiffTime)
-> Value
-> Converter DiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> Converter DiffTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> Converter DiffTime)
-> (Scientific -> DiffTime) -> Scientific -> Converter DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    {-# INLINE toValue #-}
    toValue :: DiffTime -> Value
toValue = Scientific -> Value
Number (Scientific -> Value)
-> (DiffTime -> Scientific) -> DiffTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    {-# INLINE encodeJSON #-}
    encodeJSON :: DiffTime -> Builder ()
encodeJSON = Scientific -> Builder ()
JB.scientific (Scientific -> Builder ())
-> (DiffTime -> Scientific) -> DiffTime -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | @{"seconds": SSS, "nanoseconds": NNN}@.
instance JSON SystemTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter SystemTime
fromValue = Text
-> (FlatMap Text Value -> Converter SystemTime)
-> Value
-> Converter SystemTime
forall a.
Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"SystemTime" ((FlatMap Text Value -> Converter SystemTime)
 -> Value -> Converter SystemTime)
-> (FlatMap Text Value -> Converter SystemTime)
-> Value
-> Converter SystemTime
forall a b. (a -> b) -> a -> b
$ \ FlatMap Text Value
v ->
        Int64 -> Word32 -> SystemTime
MkSystemTime (Int64 -> Word32 -> SystemTime)
-> Converter Int64 -> Converter (Word32 -> SystemTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlatMap Text Value
v FlatMap Text Value -> Text -> Converter Int64
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"seconds" Converter (Word32 -> SystemTime)
-> Converter Word32 -> Converter SystemTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FlatMap Text Value
v FlatMap Text Value -> Text -> Converter Word32
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"nanoseconds"
    {-# INLINE toValue #-}
    toValue :: SystemTime -> Value
toValue (MkSystemTime Int64
s Word32
ns) = [(Text, Value)] -> Value
object [ Text
"seconds" Text -> Int64 -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= Int64
s , Text
"nanoseconds" Text -> Word32 -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= Word32
ns ]
    {-# INLINE encodeJSON #-}
    encodeJSON :: SystemTime -> Builder ()
encodeJSON (MkSystemTime Int64
s Word32
ns) = KVItem -> Builder ()
object' (Text
"seconds" Text -> Int64 -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! Int64
s KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"nanoseconds" Text -> Word32 -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! Word32
ns)

instance JSON CalendarDiffTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter CalendarDiffTime
fromValue = Text
-> (FlatMap Text Value -> Converter CalendarDiffTime)
-> Value
-> Converter CalendarDiffTime
forall a.
Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"CalendarDiffTime" ((FlatMap Text Value -> Converter CalendarDiffTime)
 -> Value -> Converter CalendarDiffTime)
-> (FlatMap Text Value -> Converter CalendarDiffTime)
-> Value
-> Converter CalendarDiffTime
forall a b. (a -> b) -> a -> b
$ \ FlatMap Text Value
v ->
        Integer -> NominalDiffTime -> CalendarDiffTime
CalendarDiffTime (Integer -> NominalDiffTime -> CalendarDiffTime)
-> Converter Integer
-> Converter (NominalDiffTime -> CalendarDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlatMap Text Value
v FlatMap Text Value -> Text -> Converter Integer
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"months" Converter (NominalDiffTime -> CalendarDiffTime)
-> Converter NominalDiffTime -> Converter CalendarDiffTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FlatMap Text Value
v FlatMap Text Value -> Text -> Converter NominalDiffTime
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"time"
    {-# INLINE toValue #-}
    toValue :: CalendarDiffTime -> Value
toValue (CalendarDiffTime Integer
m NominalDiffTime
nt) = [(Text, Value)] -> Value
object [ Text
"months" Text -> Integer -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= Integer
m , Text
"time" Text -> NominalDiffTime -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= NominalDiffTime
nt ]
    {-# INLINE encodeJSON #-}
    encodeJSON :: CalendarDiffTime -> Builder ()
encodeJSON (CalendarDiffTime Integer
m NominalDiffTime
nt) = KVItem -> Builder ()
object' (Text
"months" Text -> Integer -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! Integer
m KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"time" Text -> NominalDiffTime -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! NominalDiffTime
nt)

instance JSON CalendarDiffDays where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter CalendarDiffDays
fromValue = Text
-> (FlatMap Text Value -> Converter CalendarDiffDays)
-> Value
-> Converter CalendarDiffDays
forall a.
Text -> (FlatMap Text Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"CalendarDiffDays" ((FlatMap Text Value -> Converter CalendarDiffDays)
 -> Value -> Converter CalendarDiffDays)
-> (FlatMap Text Value -> Converter CalendarDiffDays)
-> Value
-> Converter CalendarDiffDays
forall a b. (a -> b) -> a -> b
$ \ FlatMap Text Value
v ->
        Integer -> Integer -> CalendarDiffDays
CalendarDiffDays (Integer -> Integer -> CalendarDiffDays)
-> Converter Integer -> Converter (Integer -> CalendarDiffDays)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlatMap Text Value
v FlatMap Text Value -> Text -> Converter Integer
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"months" Converter (Integer -> CalendarDiffDays)
-> Converter Integer -> Converter CalendarDiffDays
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FlatMap Text Value
v FlatMap Text Value -> Text -> Converter Integer
forall a. JSON a => FlatMap Text Value -> Text -> Converter a
.: Text
"days"
    {-# INLINE toValue #-}
    toValue :: CalendarDiffDays -> Value
toValue (CalendarDiffDays Integer
m Integer
d) = [(Text, Value)] -> Value
object [Text
"months" Text -> Integer -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= Integer
m, Text
"days" Text -> Integer -> (Text, Value)
forall v. JSON v => Text -> v -> (Text, Value)
.= Integer
d]
    {-# INLINE encodeJSON #-}
    encodeJSON :: CalendarDiffDays -> Builder ()
encodeJSON (CalendarDiffDays Integer
m Integer
d) = KVItem -> Builder ()
object' (Text
"months" Text -> Integer -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! Integer
m KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"days" Text -> Integer -> KVItem
forall v. JSON v => Text -> v -> KVItem
.! Integer
d)

instance JSON DayOfWeek where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter DayOfWeek
fromValue (String Text
"Monday"   ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Monday
    fromValue (String Text
"Tuesday"  ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Tuesday
    fromValue (String Text
"Wednesday") = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Wednesday
    fromValue (String Text
"Thursday" ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Thursday
    fromValue (String Text
"Friday"   ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Friday
    fromValue (String Text
"Saturday" ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Saturday
    fromValue (String Text
"Sunday"   ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Sunday
    fromValue (String Text
_   )        = Text -> Converter DayOfWeek
forall a. Text -> Converter a
fail' Text
"converting DayOfWeek failed, value should be one of weekdays"
    fromValue Value
v                    = Text -> Text -> Value -> Converter DayOfWeek
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
"DayOfWeek" Text
"String" Value
v

    {-# INLINE toValue #-}
    toValue :: DayOfWeek -> Value
toValue DayOfWeek
Monday    = Text -> Value
String Text
"Monday"
    toValue DayOfWeek
Tuesday   = Text -> Value
String Text
"Tuesday"
    toValue DayOfWeek
Wednesday = Text -> Value
String Text
"Wednesday"
    toValue DayOfWeek
Thursday  = Text -> Value
String Text
"Thursday"
    toValue DayOfWeek
Friday    = Text -> Value
String Text
"Friday"
    toValue DayOfWeek
Saturday  = Text -> Value
String Text
"Saturday"
    toValue DayOfWeek
Sunday    = Text -> Value
String Text
"Sunday"

    {-# INLINE encodeJSON #-}
    encodeJSON :: DayOfWeek -> Builder ()
encodeJSON DayOfWeek
Monday    = Builder ()
"\"Monday\""
    encodeJSON DayOfWeek
Tuesday   = Builder ()
"\"Tuesday\""
    encodeJSON DayOfWeek
Wednesday = Builder ()
"\"Wednesday\""
    encodeJSON DayOfWeek
Thursday  = Builder ()
"\"Thursday\""
    encodeJSON DayOfWeek
Friday    = Builder ()
"\"Friday\""
    encodeJSON DayOfWeek
Saturday  = Builder ()
"\"Saturday\""
    encodeJSON DayOfWeek
Sunday    = Builder ()
"\"Sunday\""

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

deriving newtype instance JSON (f (g a)) => JSON (Compose f g a)
deriving newtype instance JSON a => JSON (Semigroup.Min a)
deriving newtype instance JSON a => JSON (Semigroup.Max a)
deriving newtype instance JSON a => JSON (Semigroup.First a)
deriving newtype instance JSON a => JSON (Semigroup.Last a)
deriving newtype instance JSON a => JSON (Semigroup.WrappedMonoid a)
deriving newtype instance JSON a => JSON (Semigroup.Dual a)
deriving newtype instance JSON a => JSON (Monoid.First a)
deriving newtype instance JSON a => JSON (Monoid.Last a)
deriving newtype instance JSON a => JSON (Identity a)
deriving newtype instance JSON a => JSON (Const a b)
deriving newtype instance JSON b => JSON (Tagged a b)

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

deriving newtype instance JSON CChar
deriving newtype instance JSON CSChar
deriving newtype instance JSON CUChar
deriving newtype instance JSON CShort
deriving newtype instance JSON CUShort
deriving newtype instance JSON CInt
deriving newtype instance JSON CUInt
deriving newtype instance JSON CLong
deriving newtype instance JSON CULong
deriving newtype instance JSON CPtrdiff
deriving newtype instance JSON CSize
deriving newtype instance JSON CWchar
deriving newtype instance JSON CSigAtomic
deriving newtype instance JSON CLLong
deriving newtype instance JSON CULLong
deriving newtype instance JSON CBool
deriving newtype instance JSON CIntPtr
deriving newtype instance JSON CUIntPtr
deriving newtype instance JSON CIntMax
deriving newtype instance JSON CUIntMax
deriving newtype instance JSON CClock
deriving newtype instance JSON CTime
deriving newtype instance JSON CUSeconds
deriving newtype instance JSON CSUSeconds
deriving newtype instance JSON CFloat
deriving newtype instance JSON CDouble

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

deriving anyclass instance (JSON (f a), JSON (g a), JSON a) => JSON (Sum f g a)
deriving anyclass instance (JSON a, JSON b) => JSON (Either a b)
deriving anyclass instance (JSON (f a), JSON (g a)) => JSON (Product f g a)

deriving anyclass instance (JSON a, JSON b) => JSON (a, b)
deriving anyclass instance (JSON a, JSON b, JSON c) => JSON (a, b, c)
deriving anyclass instance (JSON a, JSON b, JSON c, JSON d) => JSON (a, b, c, d)
deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e) => JSON (a, b, c, d, e)
deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e, JSON f) => JSON (a, b, c, d, e, f)
deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e, JSON f, JSON g) => JSON (a, b, c, d, e, f, g)