Z-Data-0.6.0.0: Z/Data/JSON/Base.hs
{-|
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
-- * 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.Base64 as Base64
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 v = to <$> gFromValue defaultSettings v
{-# INLINABLE fromValue #-}
toValue :: a -> Value
default toValue :: (Generic a, GToValue (Rep a)) => a -> Value
toValue = gToValue defaultSettings . from
{-# INLINABLE toValue #-}
encodeJSON :: a -> B.Builder ()
default encodeJSON :: (Generic a, GEncodeJSON (Rep a)) => a -> B.Builder ()
encodeJSON = gEncodeJSON defaultSettings . 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' = decode' . T.getUTF8Bytes
-- | Decode a JSON text, return any trailing text.
decodeText :: JSON a => T.Text -> (T.Text, Either DecodeError a)
{-# INLINE decodeText #-}
decodeText t =
let (rest, r) = decode (T.getUTF8Bytes t)
in (T.Text rest, 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' bs = case P.parse' (JV.value <* JV.skipSpaces <* P.endOfInput) bs of
Left pErr -> Left (Left pErr)
Right v -> case convertValue v of
Left cErr -> Left (Right cErr)
Right r -> Right r
-- | Decode a JSON bytes, return any trailing bytes.
decode :: JSON a => V.Bytes -> (V.Bytes, Either DecodeError a)
{-# INLINE decode #-}
decode bs = case P.parse JV.value bs of
(bs', Left pErr) -> (bs', Left (Left pErr))
(bs', Right v) -> case convertValue v of
Left cErr -> (bs', Left (Right cErr))
Right r -> (bs', Right r)
-- | Decode JSON doc chunks, return trailing bytes.
decodeChunks :: (JSON a, Monad m) => P.ParseChunks m V.Bytes DecodeError a
{-# INLINE decodeChunks #-}
decodeChunks mb bs = do
mr <- P.parseChunks JV.value mb bs
case mr of
(bs', Left pErr) -> pure (bs', Left (Left pErr))
(bs', Right v) ->
case convertValue v of
Left cErr -> pure (bs', Left (Right cErr))
Right r -> pure (bs', Right r)
-- | Directly encode data to JSON bytes.
encode :: JSON a => a -> V.Bytes
{-# INLINE encode #-}
encode = B.build . encodeJSON
-- | Encode data to JSON bytes chunks.
encodeChunks :: JSON a => a -> [V.Bytes]
{-# INLINE encodeChunks #-}
encodeChunks = B.buildChunks . encodeJSON
-- | Text version 'encode'.
encodeText :: JSON a => a -> T.Text
{-# INLINE encodeText #-}
encodeText = T.Text . encode
-- | Run a 'Converter' with input value.
convertValue :: (JSON a) => Value -> Either ConvertError a
{-# INLINE convertValue #-}
convertValue = convert 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 name expected v =
fail' $ T.concat ["converting ", name, " failed, expected ", expected, ", encountered ", actual]
where
actual = case v of
Object _ -> "Object"
Array _ -> "Array"
String _ -> "String"
Number _ -> "Number"
Bool _ -> "Boolean"
_ -> "Null"
fromNull :: T.Text -> a -> Value -> Converter a
{-# INLINE fromNull #-}
fromNull _ a Null = pure a
fromNull c _ v = typeMismatch c "Null" v
withBool :: T.Text -> (Bool -> Converter a) -> Value -> Converter a
{-# INLINE withBool #-}
withBool _ f (Bool x) = f x
withBool name _ v = typeMismatch name "Bool" 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 _ f (Number x) = f x
withScientific name _ v = typeMismatch name "Number" 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 _ f (Number s) = f (Scientific.toRealFloat s)
withRealFloat _ f Null = f (0/0)
withRealFloat name _ v = typeMismatch name "Number or Null" 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 name f (Number x)
| e <= 1024 = f x
| otherwise = fail' . B.unsafeBuildText $ do
"converting "
T.text name
" failed, found a number with exponent "
T.int e
", but it must not be greater than 1024"
where e = base10Exponent x
withBoundedScientific name _ v = typeMismatch name "Number" 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 name f (Number x) =
case toBoundedInteger x of
Just i -> f i
_ -> fail' . B.unsafeBuildText $ do
"converting "
T.text name
"failed, value is either floating or will cause over or underflow: "
T.scientific x
withBoundedIntegral name _ v = typeMismatch name "Number" v
withText :: T.Text -> (T.Text -> Converter a) -> Value -> Converter a
{-# INLINE withText #-}
withText _ f (String x) = f x
withText name _ v = typeMismatch name "String" v
withArray :: T.Text -> (V.Vector Value -> Converter a) -> Value -> Converter a
{-# INLINE withArray #-}
withArray _ f (Array arr) = f arr
withArray name _ v = typeMismatch name "Array" 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 _ f (Object kvs) = f kvs
withKeyValues name _ v = typeMismatch name "Object" 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 _ f (Object obj) = f (FM.packVector obj)
withFlatMap name _ v = typeMismatch name "Object" 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 _ f (Object obj) = f (FM.packVectorR obj)
withFlatMapR name _ v = typeMismatch name "Object" 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 _ f (Object obj) = f (HM.fromList (V.unpackR obj))
withHashMap name _ v = typeMismatch name "Object" 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 _ f (Object obj) = f (HM.fromList (V.unpack obj))
withHashMapR name _ v = typeMismatch name "Object" 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 _ innerConverter (String txt) = Converter (\ kf k ->
case decode' (T.getUTF8Bytes txt) of
Right v -> runConverter (innerConverter v) (\ paths msg -> kf (Embedded:paths) msg) k
Left (Left pErr) -> kf [] (T.intercalate ", " ("parsing embeded JSON failed ": pErr))
_ -> error "Z.JSON.Base: impossible, converting to Value should not fail")
withEmbeddedJSON name _ v = typeMismatch name "String" 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 (.:) #-}
(.:) = convertField 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 (.:?) #-}
(.:?) = convertFieldMaybe 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 (.:!) #-}
(.:!) = convertFieldMaybe' 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 p obj key = case FM.lookup key obj of
Just v -> p v <?> Key key
_ -> fail' (T.concat $ ["key ", key, " 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 p obj key = case FM.lookup key obj of
Just Null -> pure Nothing
Just v -> Just <$> p v <?> Key key
_ -> pure Nothing
-- | Variant of '.:!' with explicit converter function.
convertFieldMaybe' :: (Value -> Converter a) -> FM.FlatMap T.Text Value -> T.Text -> Converter (Maybe a)
{-# INLINE convertFieldMaybe' #-}
convertFieldMaybe' p obj key = case FM.lookup key obj of
Just v -> Just <$> p v <?> Key key
_ -> pure Nothing
--------------------------------------------------------------------------------
-- | Use @,@ as separator to connect list of builders.
commaSepList :: JSON a => [a] -> B.Builder ()
{-# INLINE commaSepList #-}
commaSepList = B.intercalateList B.comma encodeJSON
-- | Use @,@ as separator to connect a vector of builders.
commaSepVec :: (JSON a, V.Vec v a) => v a -> B.Builder ()
{-# INLINE commaSepVec #-}
commaSepVec = B.intercalateVec B.comma 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 a <> KVItem b = KVItem (a >> B.comma >> b)
-- | Connect key and value to a 'KVItem' using 'B.colon', key will be escaped.
(.!) :: JSON v => T.Text -> v -> KVItem
{-# INLINE (.!) #-}
k .! v = KVItem (k `JB.kv'` encodeJSON v)
infixr 8 .!
-- | Add curly for comma connected 'KVItem's.
object' :: KVItem -> B.Builder ()
{-# INLINE object' #-}
object' (KVItem kvb) = B.curly kvb
-- | Connect key and value to a tuple to be used with 'object'.
(.=) :: JSON v => T.Text -> v -> (T.Text, Value)
{-# INLINE (.=) #-}
k .= v = let !v' = toValue v in (k, v')
infixr 8 .=
-- | Alias for @Object . pack@.
object :: [(T.Text, Value)] -> Value
{-# INLINE object #-}
object = Object . 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
{ fieldFmt :: String -> T.Text -- ^ format field labels
, constrFmt :: String -> T.Text -- ^ format constructor names
, missingKeyAsNull :: Bool -- ^ take missing field as 'Null'?
}
-- | @Settings T.pack T.pack False@
defaultSettings :: Settings
defaultSettings = Settings T.pack T.pack 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 s marr idx (a :*: b) = do
gWriteFields s marr idx a
gWriteFields s marr (idx + productSize (proxy# :: Proxy# a)) b
instance (GToValue f) => GWriteFields (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gWriteFields #-}
gWriteFields s marr idx (M1 x) = A.writeSmallArray marr idx (gToValue s x)
instance (GToValue f, Selector (MetaSel (Just l) u ss ds)) => GWriteFields (S1 (MetaSel (Just l) u ss ds) f) where
{-# INLINE gWriteFields #-}
gWriteFields s marr idx m1@(M1 x) = A.writeSmallArray marr idx ((fieldFmt s) (selName m1), gToValue s x)
instance (GToValue f, Selector (MetaSel (Just l) u ss ds)) => GToValue (S1 (MetaSel (Just l) u ss ds) f) where
{-# INLINE gToValue #-}
gToValue s m1@(M1 x) =
let !k = fieldFmt s $ selName m1
!v = gToValue s x
in Object (V.singleton (k, v))
instance GToValue f => GToValue (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gToValue #-}
gToValue s (M1 x) = gToValue s x
instance JSON a => GToValue (K1 i a) where
{-# INLINE gToValue #-}
gToValue _ (K1 x) = toValue 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 _ = gMergeFields (proxy# :: Proxy# a)
instance GMergeFields (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gMergeFields #-}
gMergeFields _ marr = do
arr <- A.unsafeFreezeSmallArray marr
let l = A.sizeofSmallArray arr
pure (Array (V.Vector arr 0 l))
instance GMergeFields (S1 (MetaSel (Just l) u ss ds) f) where
{-# INLINE gMergeFields #-}
gMergeFields _ marr = do
arr <- A.unsafeFreezeSmallArray marr
let l = A.sizeofSmallArray arr
pure (Object (V.Vector arr 0 l))
--------------------------------------------------------------------------------
-- Constructors
class GConstrToValue f where
gConstrToValue :: Bool -> Settings -> f a -> Value
instance GConstrToValue V1 where
{-# INLINE gConstrToValue #-}
gConstrToValue _ _ _ = error "Z.Data.JSON.Base: empty data type"
instance (GConstrToValue f, GConstrToValue g) => GConstrToValue (f :+: g) where
{-# INLINE gConstrToValue #-}
gConstrToValue _ s (L1 x) = gConstrToValue True s x
gConstrToValue _ s (R1 x) = gConstrToValue True s x
-- | Constructor without payload, convert to String
instance (Constructor c) => GConstrToValue (C1 c U1) where
{-# INLINE gConstrToValue #-}
gConstrToValue _ s (M1 _) = String . constrFmt s $ conName (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 False s (M1 x) = gToValue s x
gConstrToValue True s (M1 x) =
let !k = constrFmt s $ conName @c undefined
!v = gToValue s x
in Object (V.singleton (k, 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 False s (M1 x) = runST (do
marr <- A.newSmallArray (productSize (proxy# :: Proxy# (a :*: b))) undefined
gWriteFields s marr 0 x
gMergeFields (proxy# :: Proxy# (a :*: b)) marr)
gConstrToValue True s (M1 x) =
let !k = constrFmt s $ conName @c undefined
!v = runST (do
marr <- A.newSmallArray (productSize (proxy# :: Proxy# (a :*: b))) undefined
gWriteFields s marr 0 x
gMergeFields (proxy# :: Proxy# (a :*: b)) marr)
in Object (V.singleton (k, v))
--------------------------------------------------------------------------------
-- Data types
instance GConstrToValue f => GToValue (D1 c f) where
{-# INLINE gToValue #-}
gToValue s (M1 x) = gConstrToValue False s 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 s m1@(M1 x) = (fieldFmt s $ selName m1) `JB.kv` gEncodeJSON s x
instance GEncodeJSON f => GEncodeJSON (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gEncodeJSON #-}
gEncodeJSON s (M1 x) = gEncodeJSON s x
instance (GEncodeJSON a, GEncodeJSON b) => GEncodeJSON (a :*: b) where
{-# INLINE gEncodeJSON #-}
gEncodeJSON s (a :*: b) = gEncodeJSON s a >> B.comma >> gEncodeJSON s b
instance JSON a => GEncodeJSON (K1 i a) where
{-# INLINE gEncodeJSON #-}
gEncodeJSON _ (K1 x) = encodeJSON x
class GAddPunctuation (f :: * -> *) where
gAddPunctuation :: Proxy# f -> B.Builder () -> B.Builder ()
instance GAddPunctuation a => GAddPunctuation (a :*: b) where
{-# INLINE gAddPunctuation #-}
gAddPunctuation _ = gAddPunctuation (proxy# :: Proxy# a)
instance GAddPunctuation (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gAddPunctuation #-}
gAddPunctuation _ b = B.square b
instance GAddPunctuation (S1 (MetaSel (Just l) u ss ds) f) where
{-# INLINE gAddPunctuation #-}
gAddPunctuation _ b = B.curly b
--------------------------------------------------------------------------------
-- Constructors
class GConstrEncodeJSON f where
gConstrEncodeJSON :: Bool -> Settings -> f a -> B.Builder ()
instance GConstrEncodeJSON V1 where
{-# INLINE gConstrEncodeJSON #-}
gConstrEncodeJSON _ _ _ = error "Z.Data.JSON.Base: empty data type"
instance (GConstrEncodeJSON f, GConstrEncodeJSON g) => GConstrEncodeJSON (f :+: g) where
{-# INLINE gConstrEncodeJSON #-}
gConstrEncodeJSON _ s (L1 x) = gConstrEncodeJSON True s x
gConstrEncodeJSON _ s (R1 x) = gConstrEncodeJSON True s 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 _ s (M1 _) = B.quotes $
B.text . constrFmt s $ conName (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 False s (M1 x) = gEncodeJSON s x
gConstrEncodeJSON True s (M1 x) = B.curly $ do
(constrFmt s $ conName @c undefined) `JB.kv` gEncodeJSON s 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 False s (M1 x) = B.curly (gEncodeJSON s x)
gConstrEncodeJSON True s (M1 x) = B.curly $ do
(constrFmt s $ conName @c undefined) `JB.kv` B.curly (gEncodeJSON s x)
-- | Constructor with multiple payloads
instance (GEncodeJSON (a :*: b), GAddPunctuation (a :*: b), Constructor c)
=> GConstrEncodeJSON (C1 c (a :*: b)) where
{-# INLINE gConstrEncodeJSON #-}
gConstrEncodeJSON False s (M1 x) = gAddPunctuation (proxy# :: Proxy# (a :*: b)) (gEncodeJSON s x)
gConstrEncodeJSON True s (M1 x) = B.curly $ do
(constrFmt s $ conName @c @_ @_ @_ undefined) `JB.kv`
gAddPunctuation (proxy# :: Proxy# (a :*: b)) (gEncodeJSON s x)
--------------------------------------------------------------------------------
-- Data types
instance GConstrEncodeJSON f => GEncodeJSON (D1 c f) where
{-# INLINE gEncodeJSON #-}
gEncodeJSON s (M1 x) = gConstrEncodeJSON False s 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 s v idx = do
!a <- gFromFields s v idx
!b <- gFromFields s v (idx + productSize (proxy# :: Proxy# a))
pure (a :*: b)
instance (GFromValue f) => GFromFields (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gFromFields #-}
gFromFields s v idx = do
v' <- V.unsafeIndexM v idx
M1 <$> gFromValue s v' <?> Index idx
instance (GFromValue f, Selector (MetaSel (Just l) u ss ds)) => GFromFields (S1 (MetaSel (Just l) u ss ds) f) where
{-# INLINE gFromFields #-}
gFromFields s v _ = do
case FM.lookup fn v of
Just v' -> M1 <$> gFromValue s v' <?> Key fn
_ | missingKeyAsNull s -> M1 <$> gFromValue s Null <?> Key fn
| otherwise -> fail' ("Z.Data.JSON.Base: missing field " <> fn)
where
fn = (fieldFmt s) (selName (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 s x = M1 <$> gFromValue s x
instance (GFromValue f, Selector (MetaSel (Just l) u ss ds)) => GFromValue (S1 (MetaSel (Just l) u ss ds) f) where
{-# INLINE gFromValue #-}
gFromValue s (Object v) = do
case FM.lookup fn (FM.packVectorR v) of
Just v' -> M1 <$> gFromValue s v' <?> Key fn
_ | missingKeyAsNull s -> M1 <$> gFromValue s Null <?> Key fn
| otherwise -> fail' ("Z.Data.JSON.Base: missing field " <> fn)
where fn = (fieldFmt s) (selName (undefined :: S1 (MetaSel (Just l) u ss ds) f a))
gFromValue s v = typeMismatch ("field " <> fn) "Object" v <?> Key fn
where fn = (fieldFmt s) (selName (undefined :: S1 (MetaSel (Just l) u ss ds) f a))
instance JSON a => GFromValue (K1 i a) where
{-# INLINE gFromValue #-}
gFromValue _ x = K1 <$> fromValue 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 _ siz = gBuildLookup (proxy# :: Proxy# a) siz
instance GBuildLookup (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gBuildLookup #-}
gBuildLookup _ siz name (Array v)
-- we have to check size here to use 'unsafeIndexM' later
| siz' /= siz = fail' . B.unsafeBuildText $ do
"converting "
T.text name
" failed, product size mismatch, expected "
T.int siz
", get"
T.int siz'
| otherwise = pure v
where siz' = V.length v
gBuildLookup _ _ name x = typeMismatch name "Array" 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 _ _ _ (Object v) = pure $! FM.packVectorR v
gBuildLookup _ _ name x = typeMismatch name "Object" 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 _ _ _ = error "Z.Data.JSON.Base: empty data type"
instance (GConstrFromValue f, GConstrFromValue g) => GConstrFromValue (f :+: g) where
{-# INLINE gConstrFromValue #-}
gConstrFromValue _ s x = (L1 <$> gConstrFromValue True s x) <|> (R1 <$> gConstrFromValue True s x)
-- | Constructor without payload, convert to String
instance (Constructor c) => GConstrFromValue (C1 c U1) where
{-# INLINE gConstrFromValue #-}
gConstrFromValue _ s (String x)
| cn == x = pure (M1 U1)
| otherwise = fail' . T.concat $ ["converting ", cn', "failed, unknown constructor name ", x]
where cn = constrFmt s $ conName (undefined :: t c U1 a)
cn' = T.pack $ conName (undefined :: t c U1 a)
gConstrFromValue _ _ v = typeMismatch cn' "String" v
where cn' = T.pack $ conName (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 False s x = M1 <$> gFromValue s x
gConstrFromValue True s x = case x of
Object v -> case V.indexM v 0 of
Just (k, v') | k == cn -> M1 <$> gFromValue s v' <?> Key cn
_ -> fail' .T.concat $ ["converting ", cn', " failed, constructor not found"]
_ -> typeMismatch cn' "Object" x
where cn = constrFmt s $ conName @c undefined
cn' = T.pack $ conName @c 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 False s x = do
t <- gBuildLookup p (productSize p) cn' x
M1 <$> gFromFields s t 0
where cn' = T.pack $ conName @c undefined
p = proxy# :: Proxy# (a :*: b)
gConstrFromValue True s x = case x of
Object v -> case V.indexM v 0 of
Just (k, v') | k == cn -> do t <- gBuildLookup p (productSize p) cn' v'
M1 <$> gFromFields s t 0
_ -> fail' .T.concat $ ["converting ", cn', " failed, constructor not found"]
_ -> typeMismatch cn' "Object" x
where cn = constrFmt s $ conName @c undefined
cn' = T.pack $ conName @c undefined
p = proxy# :: Proxy# (a :*: b)
--------------------------------------------------------------------------------
-- Data types
instance GConstrFromValue f => GFromValue (D1 c f) where
{-# INLINE gFromValue #-}
gFromValue s x = M1 <$> gConstrFromValue False s x
--------------------------------------------------------------------------------
-- Built-in Instances
--------------------------------------------------------------------------------
-- | Use 'Null' as @Proxy a@
instance JSON (Proxy a) where
{-# INLINE fromValue #-}; fromValue = fromNull "Proxy" Proxy;
{-# INLINE toValue #-}; toValue _ = Null;
{-# INLINE encodeJSON #-}; encodeJSON _ = "null";
instance JSON Value where
{-# INLINE fromValue #-}; fromValue = pure;
{-# INLINE toValue #-}; toValue = id;
{-# INLINE encodeJSON #-}; encodeJSON = JB.value;
instance JSON T.Text where
{-# INLINE fromValue #-}; fromValue = withText "Text" pure;
{-# INLINE toValue #-}; toValue = String;
{-# INLINE encodeJSON #-}; encodeJSON = JB.string;
-- | Note this instance doesn't reject large input
instance JSON Scientific where
{-# INLINE fromValue #-}; fromValue = withScientific "Scientific" pure;
{-# INLINE toValue #-}; toValue = Number;
{-# INLINE encodeJSON #-}; encodeJSON = JB.scientific;
-- | default instance prefer later key
instance JSON a => JSON (FM.FlatMap T.Text a) where
{-# INLINE fromValue #-}
fromValue = withFlatMapR "Z.Data.Vector.FlatMap.FlatMap"
(FM.traverseWithKey $ \ k v -> fromValue v <?> Key k)
{-# INLINE toValue #-}
toValue = Object . FM.sortedKeyValues . FM.map' toValue
{-# INLINE encodeJSON #-}
encodeJSON = JB.object' encodeJSON . FM.sortedKeyValues
instance (Ord a, JSON a) => JSON (FS.FlatSet a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Vector.FlatSet.FlatSet" $ \ vs ->
FS.packRN (V.length vs) <$>
(zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs))
{-# INLINE toValue #-}
toValue = Array . V.map' toValue . FS.sortedValues
{-# INLINE encodeJSON #-}
encodeJSON = JB.array' encodeJSON . FS.sortedValues
-- | default instance prefer later key
instance JSON a => JSON (HM.HashMap T.Text a) where
{-# INLINE fromValue #-}
fromValue = withHashMapR "Data.HashMap.HashMap"
(HM.traverseWithKey $ \ k v -> fromValue v <?> Key k)
{-# INLINE toValue #-}
toValue = Object . V.pack . HM.toList . HM.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.curly . B.intercalateList B.comma (\ (k, v) -> k `JB.kv'` encodeJSON v) . HM.toList
instance JSON a => JSON (M.Map T.Text a) where
{-# INLINE fromValue #-}
fromValue = withKeyValues "Data.Map.Map" $
(M.traverseWithKey (\ k v -> fromValue v <?> Key k)) . M.fromList . V.unpack
{-# INLINE toValue #-}
toValue = Object . V.pack . M.toList . M.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.curly . B.intercalateList B.comma (\ (k, v) -> k `JB.kv'` encodeJSON v) . M.toList
instance JSON a => JSON (FIM.FlatIntMap a) where
{-# INLINE fromValue #-}
fromValue = withFlatMapR "Z.Data.Vector.FlatIntMap.FlatIntMap" $ \ m ->
let kvs = FM.sortedKeyValues m
in FIM.packVectorR <$> (forM kvs $ \ (k, v) -> do
case P.parse' P.int (T.getUTF8Bytes k) of
Right k' -> do
v' <- fromValue v <?> Key k
return (V.IPair k' v')
_ -> fail' ("converting Z.Data.Vector.FlatIntMap.FlatIntMap failed, unexpected key " <> k))
{-# INLINE toValue #-}
toValue = Object . V.map' toKV . FIM.sortedKeyValues
where toKV (V.IPair i x) = let !k = T.toText i
!v = toValue x
in (k, v)
{-# INLINE encodeJSON #-}
encodeJSON = B.curly . B.intercalateVec B.comma (\ (V.IPair i x) -> do
B.quotes (B.int i)
B.colon
encodeJSON x) . FIM.sortedKeyValues
instance JSON a => JSON (IM.IntMap a) where
{-# INLINE fromValue #-}
fromValue = withKeyValues "Data.IntMap.IntMap" $ \ kvs ->
IM.fromList <$> (forM (V.unpack kvs) $ \ (k, v) -> do
case P.parse' P.int (T.getUTF8Bytes k) of
Right k' -> do
!v' <- fromValue v <?> Key k
return (k', v')
_ -> fail' ("converting Data.IntMap.IntMap failed, unexpected key " <> k))
{-# INLINE toValue #-}
toValue = Object . V.pack . map toKV . IM.toList
where toKV (i, x) = let !k = T.toText i
!v = toValue x
in (k, v)
{-# INLINE encodeJSON #-}
encodeJSON = B.curly . B.intercalateList B.comma (\ (i, x) -> do
B.quotes (B.int i)
B.colon
encodeJSON x) . IM.toList
instance JSON FIS.FlatIntSet where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Vector.FlatIntSet.FlatIntSet" $ \ vs ->
FIS.packRN (V.length vs) <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
{-# INLINE toValue #-}
toValue = toValue . FIS.sortedValues
{-# INLINE encodeJSON #-}
encodeJSON = encodeJSON . FIS.sortedValues
instance JSON IS.IntSet where
{-# INLINE fromValue #-}
fromValue = withArray "Data.IntSet.IntSet" $ \ vs ->
IS.fromList <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
{-# INLINE toValue #-}
toValue = toValue . IS.toList
{-# INLINE encodeJSON #-}
encodeJSON = encodeJSON . IS.toList
instance (Ord a, JSON a) => JSON (Set.Set a) where
{-# INLINE fromValue #-}
fromValue = withArray "Data.Set.Set" $ \ vs ->
Set.fromList <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
{-# INLINE toValue #-}
toValue = toValue . Set.toList
{-# INLINE encodeJSON #-}
encodeJSON = encodeJSON . Set.toList
instance JSON a => JSON (Seq.Seq a) where
{-# INLINE fromValue #-}
fromValue = withArray "Data.Seq.Seq" $ \ vs ->
Seq.fromList <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
{-# INLINE toValue #-}
toValue = toValue . Foldable.toList
{-# INLINE encodeJSON #-}
encodeJSON = encodeJSON . Foldable.toList
instance JSON a => JSON (Tree.Tree a) where
{-# INLINE fromValue #-}
fromValue = withFlatMapR "Data.Tree" $ \obj -> do
!n <- obj .: "rootLabel"
!d <- obj .: "subForest"
pure (Tree.Node n d)
{-# INLINE toValue #-}
toValue x = object [ "rootLabel" .= (Tree.rootLabel x) , "subForest" .= (Tree.subForest x) ]
{-# INLINE encodeJSON #-}
encodeJSON x = object' ( "rootLabel" .! (Tree.rootLabel x) <> "subForest" .! (Tree.subForest x) )
instance JSON a => JSON (A.Array a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Array.Array"
(V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
{-# INLINE toValue #-}
toValue = Array . V.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.square . commaSepVec
instance JSON a => JSON (A.SmallArray a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Array.SmallArray"
(V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
{-# INLINE toValue #-}
toValue = Array . V.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.square . commaSepVec
instance (Prim a, JSON a) => JSON (A.PrimArray a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Array.PrimArray"
(V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
{-# INLINE toValue #-}
toValue = Array . V.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.square . commaSepVec
instance JSON A.ByteArray where
{-# INLINE fromValue #-}
fromValue value = do
(A.PrimArray ba# :: A.PrimArray Word8) <-
withArray "Data.Primitive.ByteArray"
(V.traverseWithIndex $ \ k v -> fromValue v <?> Index k) value
return (A.ByteArray ba#)
{-# INLINE toValue #-}
toValue (A.ByteArray ba#) =
Array (V.map toValue (A.PrimArray ba# :: A.PrimArray Word8))
{-# INLINE encodeJSON #-}
encodeJSON (A.ByteArray ba#) =
B.square (commaSepVec (A.PrimArray ba# :: A.PrimArray Word8))
instance (A.PrimUnlifted a, JSON a) => JSON (A.UnliftedArray a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Array.UnliftedArray"
(V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
{-# INLINE toValue #-}
toValue = Array . V.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.square . commaSepVec
instance JSON a => JSON (V.Vector a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Vector.Vector"
(V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
{-# INLINE toValue #-}
toValue = Array . V.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.square . commaSepVec
instance (Prim a, JSON a) => JSON (V.PrimVector a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Vector.PrimVector"
(V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
{-# INLINE toValue #-}
toValue = Array . V.map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.square . commaSepVec
-- | This is an INCOHERENT instance, encode binary data with base64 encoding.
instance {-# INCOHERENT #-} JSON V.Bytes where
fromValue = withText "Z.Data.Vector.Bytes" $ \ t ->
case Base64.base64Decode (T.getUTF8Bytes t) of
Just bs -> pure bs
Nothing -> fail' "illegal base64 encoding bytes"
{-# INLINE toValue #-}
toValue = String . Base64.base64EncodeText
{-# INLINE encodeJSON #-}
encodeJSON = B.quotes . Base64.base64EncodeBuilder
instance (Eq a, Hashable a, JSON a) => JSON (HS.HashSet a) where
{-# INLINE fromValue #-}
fromValue = withArray "Z.Data.Vector.FlatSet.FlatSet" $ \ vs ->
HS.fromList <$>
(zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs))
{-# INLINE toValue #-}
toValue = toValue . HS.toList
{-# INLINE encodeJSON #-}
encodeJSON = encodeJSON . HS.toList
instance JSON a => JSON [a] where
{-# INLINE fromValue #-}
fromValue = withArray "[a]" $ \ vs ->
zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
{-# INLINE toValue #-}
toValue = Array . V.pack . map toValue
{-# INLINE encodeJSON #-}
encodeJSON = B.square . commaSepList
-- | This is an INCOHERENT instance, to provide JSON text encoding behaviour.
instance {-# INCOHERENT #-} JSON [Char] where
{-# INLINE fromValue #-}
fromValue = withText "String" (pure . T.unpack)
{-# INLINE toValue #-}
toValue = String . T.pack
{-# INLINE encodeJSON #-}
encodeJSON = JB.string . T.pack
instance JSON a => JSON (NonEmpty a) where
{-# INLINE fromValue #-}
fromValue = withArray "NonEmpty" $ \ vs -> do
l <- zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
case l of (x:xs) -> pure (x :| xs)
_ -> fail' "unexpected empty array"
{-# INLINE toValue #-}
toValue = toValue . NonEmpty.toList
{-# INLINE encodeJSON #-}
encodeJSON = encodeJSON . NonEmpty.toList
instance JSON Bool where
{-# INLINE fromValue #-}; fromValue = withBool "Bool" pure;
{-# INLINE toValue #-}; toValue = Bool;
{-# INLINE encodeJSON #-}; encodeJSON True = "true"; encodeJSON _ = "false";
instance JSON Char where
{-# INLINE fromValue #-}
fromValue = withText "Char" $ \ t ->
if (T.length t == 1)
then pure (T.head t)
else fail' (T.concat ["converting Char failed, expected a string of length 1"])
{-# INLINE toValue #-}
toValue = String . T.singleton
-- @
-- \'\\b\': \"\\b\"
-- \'\\f\': \"\\f\"
-- \'\\n\': \"\\n\"
-- \'\\r\': \"\\r\"
-- \'\\t\': \"\\t\"
-- \'\"\': \"\\\"\"
-- \'\\\': \"\\\\\"
-- other chars <= 0x1F: "\\u00XX"
-- @
{-# INLINE encodeJSON #-}
encodeJSON '\b' = "\"\\b\""
encodeJSON '\f' = "\"\\f\""
encodeJSON '\n' = "\"\\n\""
encodeJSON '\r' = "\"\\r\""
encodeJSON '\t' = "\"\\t\""
encodeJSON '\"' = "\"\\\"\""
encodeJSON '\\' = "\"\\\\\""
encodeJSON c | c <= '\US' = "\"\\u00" >> B.hex (fromIntegral (ord c) :: Word8) >> B.char8 '\"'
| otherwise = B.quotes (B.charUTF8 c)
instance JSON Double where
{-# INLINE fromValue #-}; fromValue = withRealFloat "Double" pure;
{-# INLINE toValue #-}; toValue = Number . P.doubleToScientific;
{-# INLINE encodeJSON #-}; encodeJSON = B.double;
instance JSON Float where
{-# INLINE fromValue #-}; fromValue = withRealFloat "Float" pure;
{-# INLINE toValue #-}; toValue = Number . P.floatToScientific;
{-# INLINE encodeJSON #-}; encodeJSON = 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 = withBoundedScientific "Integer" $ \ n ->
case Scientific.floatingOrInteger n :: Either Double Integer of
Right x -> pure x
Left _ -> fail' . B.unsafeBuildText $ do
"converting Integer failed, unexpected floating number "
T.scientific n
{-# INLINE toValue #-}
toValue = Number . fromIntegral
{-# INLINE encodeJSON #-}
encodeJSON = 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 = withBoundedScientific "Natural" $ \ n ->
if n < 0
then fail' . B.unsafeBuildText $ do
"converting Natural failed, unexpected negative number "
T.scientific n
else case Scientific.floatingOrInteger n :: Either Double Natural of
Right x -> pure x
Left _ -> fail' . B.unsafeBuildText $ do
"converting Natural failed, unexpected floating number "
T.scientific n
{-# INLINE toValue #-}
toValue = Number . fromIntegral
{-# INLINE encodeJSON #-}
encodeJSON = B.integer . fromIntegral
instance JSON Ordering where
{-# INLINE fromValue #-}
fromValue = withText "Ordering" $ \ s ->
case s of
"LT" -> pure LT
"EQ" -> pure EQ
"GT" -> pure GT
_ -> fail' . T.concat $ ["converting Ordering failed, unexpected ",
s, " expected \"LT\", \"EQ\", or \"GT\""]
{-# INLINE toValue #-}
toValue LT = String "LT"
toValue EQ = String "EQ"
toValue GT = String "GT"
{-# INLINE encodeJSON #-}
encodeJSON LT = "\"LT\""
encodeJSON EQ = "\"EQ\""
encodeJSON GT = "\"GT\""
instance JSON () where
{-# INLINE fromValue #-}
fromValue = withArray "()" $ \ v ->
if V.null v
then pure ()
else fail' "converting () failed, expected an empty array"
{-# INLINE toValue #-}
toValue () = Array V.empty
{-# INLINE encodeJSON #-}
encodeJSON () = "[]"
instance JSON ExitCode where
{-# INLINE fromValue #-}
fromValue (String "ExitSuccess") = return ExitSuccess
fromValue (Number x) =
case toBoundedInteger x of
Just i -> return (ExitFailure i)
_ -> fail' . B.unsafeBuildText $ do
"converting ExitCode failed, value is either floating or will cause over or underflow: "
T.scientific x
fromValue _ = fail' "converting ExitCode failed, expected a string or number"
{-# INLINE toValue #-}
toValue ExitSuccess = String "ExitSuccess"
toValue (ExitFailure n) = Number (fromIntegral n)
{-# INLINE encodeJSON #-}
encodeJSON ExitSuccess = "\"ExitSuccess\""
encodeJSON (ExitFailure n) = B.int n
-- | Only round trip 'versionBranch' as JSON array.
instance JSON Version where
{-# INLINE fromValue #-}
fromValue v = makeVersion <$> fromValue v
{-# INLINE toValue #-}
toValue = toValue . versionBranch
{-# INLINE encodeJSON #-}
encodeJSON = encodeJSON . versionBranch
instance JSON a => JSON (Maybe a) where
{-# INLINE fromValue #-}
fromValue Null = pure Nothing
fromValue v = Just <$> fromValue v
{-# INLINE toValue #-}
toValue Nothing = Null
toValue (Just x) = toValue x
{-# INLINE encodeJSON #-}
encodeJSON Nothing = "null"
encodeJSON (Just x) = encodeJSON 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 = withFlatMapR "Rational" $ \obj -> do
!n <- obj .: "numerator"
!d <- obj .: "denominator"
if d == 0
then fail' "Ratio denominator was 0"
else pure (n % d)
{-# INLINE toValue #-}
toValue x = object [ "numerator" .= (numerator x) , "denominator" .= (denominator x) ]
{-# INLINE encodeJSON #-}
encodeJSON x = object' ( "numerator" .! (numerator x) <> "denominator" .! (denominator 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 = withBoundedScientific "Fixed" (pure . realToFrac)
{-# INLINE toValue #-}
toValue = Number . realToFrac
{-# INLINE encodeJSON #-}
encodeJSON = JB.scientific . realToFrac
--------------------------------------------------------------------------------
-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance JSON UTCTime where
{-# INLINE fromValue #-}
fromValue = withText "UTCTime" $ \ t ->
case P.parse' (P.utcTime <* P.endOfInput) (T.getUTF8Bytes t) of
Left err -> fail' $ "could not parse date as UTCTime: " <> T.toText err
Right r -> return r
{-# INLINE toValue #-}
toValue t = String (B.unsafeBuildText (B.utcTime t))
{-# INLINE encodeJSON #-}
encodeJSON = B.quotes . B.utcTime
-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance JSON ZonedTime where
{-# INLINE fromValue #-}
fromValue = withText "ZonedTime" $ \ t ->
case P.parse' (P.zonedTime <* P.endOfInput) (T.getUTF8Bytes t) of
Left err -> fail' $ "could not parse date as ZonedTime: " <> T.toText err
Right r -> return r
{-# INLINE toValue #-}
toValue t = String (B.unsafeBuildText (B.zonedTime t))
{-# INLINE encodeJSON #-}
encodeJSON = B.quotes . B.zonedTime
-- | @YYYY-MM-DD@
instance JSON Day where
{-# INLINE fromValue #-}
fromValue = withText "Day" $ \ t ->
case P.parse' (P.day <* P.endOfInput) (T.getUTF8Bytes t) of
Left err -> fail' $ "could not parse date as Day: " <> T.toText err
Right r -> return r
{-# INLINE toValue #-}
toValue t = String (B.unsafeBuildText (B.day t))
{-# INLINE encodeJSON #-}
encodeJSON = B.quotes . B.day
-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance JSON LocalTime where
{-# INLINE fromValue #-}
fromValue = withText "LocalTime" $ \ t ->
case P.parse' (P.localTime <* P.endOfInput) (T.getUTF8Bytes t) of
Left err -> fail' $ "could not parse date as LocalTime: " <> T.toText err
Right r -> return r
{-# INLINE toValue #-}
toValue t = String (B.unsafeBuildText (B.localTime t))
{-# INLINE encodeJSON #-}
encodeJSON = B.quotes . B.localTime
-- | @HH:MM:SS.SSS@
instance JSON TimeOfDay where
{-# INLINE fromValue #-}
fromValue = withText "TimeOfDay" $ \ t ->
case P.parse' (P.timeOfDay <* P.endOfInput) (T.getUTF8Bytes t) of
Left err -> fail' $ "could not parse time as TimeOfDay: " <> T.toText err
Right r -> return r
{-# INLINE toValue #-}
toValue t = String (B.unsafeBuildText (B.timeOfDay t))
{-# INLINE encodeJSON #-}
encodeJSON = B.quotes . 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 = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
{-# INLINE toValue #-}
toValue = Number . realToFrac
{-# INLINE encodeJSON #-}
encodeJSON = JB.scientific . 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 = withBoundedScientific "DiffTime" $ pure . realToFrac
{-# INLINE toValue #-}
toValue = Number . realToFrac
{-# INLINE encodeJSON #-}
encodeJSON = JB.scientific . realToFrac
-- | @{"seconds": SSS, "nanoseconds": NNN}@.
instance JSON SystemTime where
{-# INLINE fromValue #-}
fromValue = withFlatMapR "SystemTime" $ \ v ->
MkSystemTime <$> v .: "seconds" <*> v .: "nanoseconds"
{-# INLINE toValue #-}
toValue (MkSystemTime s ns) = object [ "seconds" .= s , "nanoseconds" .= ns ]
{-# INLINE encodeJSON #-}
encodeJSON (MkSystemTime s ns) = object' ("seconds" .! s <> "nanoseconds" .! ns)
instance JSON CalendarDiffTime where
{-# INLINE fromValue #-}
fromValue = withFlatMapR "CalendarDiffTime" $ \ v ->
CalendarDiffTime <$> v .: "months" <*> v .: "time"
{-# INLINE toValue #-}
toValue (CalendarDiffTime m nt) = object [ "months" .= m , "time" .= nt ]
{-# INLINE encodeJSON #-}
encodeJSON (CalendarDiffTime m nt) = object' ("months" .! m <> "time" .! nt)
instance JSON CalendarDiffDays where
{-# INLINE fromValue #-}
fromValue = withFlatMapR "CalendarDiffDays" $ \ v ->
CalendarDiffDays <$> v .: "months" <*> v .: "days"
{-# INLINE toValue #-}
toValue (CalendarDiffDays m d) = object ["months" .= m, "days" .= d]
{-# INLINE encodeJSON #-}
encodeJSON (CalendarDiffDays m d) = object' ("months" .! m <> "days" .! d)
instance JSON DayOfWeek where
{-# INLINE fromValue #-}
fromValue (String "Monday" ) = pure Monday
fromValue (String "Tuesday" ) = pure Tuesday
fromValue (String "Wednesday") = pure Wednesday
fromValue (String "Thursday" ) = pure Thursday
fromValue (String "Friday" ) = pure Friday
fromValue (String "Saturday" ) = pure Saturday
fromValue (String "Sunday" ) = pure Sunday
fromValue (String _ ) = fail' "converting DayOfWeek failed, value should be one of weekdays"
fromValue v = typeMismatch "DayOfWeek" "String" v
{-# INLINE toValue #-}
toValue Monday = String "Monday"
toValue Tuesday = String "Tuesday"
toValue Wednesday = String "Wednesday"
toValue Thursday = String "Thursday"
toValue Friday = String "Friday"
toValue Saturday = String "Saturday"
toValue Sunday = String "Sunday"
{-# INLINE encodeJSON #-}
encodeJSON Monday = "\"Monday\""
encodeJSON Tuesday = "\"Tuesday\""
encodeJSON Wednesday = "\"Wednesday\""
encodeJSON Thursday = "\"Thursday\""
encodeJSON Friday = "\"Friday\""
encodeJSON Saturday = "\"Saturday\""
encodeJSON Sunday = "\"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)