{-# OPTIONS_GHC -fno-warn-orphans #-}

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

Types and functions for working efficiently with JSON data, the design is quite similar to @aeson@ or @json@:

  * Encode to bytes can be done directly via 'encodeJSON'.
  * Decode are split in two step, first we parse JSON doc into 'Value', then convert to haskell data via 'fromValue'.
  * 'ToValue' are provided so that other doc formats can be easily supported, such as 'YAML'.

Note this module also provides many (orphan)instances to reduce the compilation stress of a gaint 'Z.Data.JSON.Base' module.

-}
module Z.Data.JSON
  ( -- * How to use this module
    -- $use
    -- ** Custom settings
    -- $custom-settings
    -- ** Write instances manually
    -- $manually-instance

    -- * JSON Class
    JSON(..), Value(..), defaultSettings, Settings(..)
  , snakeCase, trainCase
    -- * Encode & Decode
  , DecodeError
  , decode, decode', decodeText, decodeText'
  , ParseChunks, decodeChunks
  , encode, encodeChunks, encodeText
  , prettyJSON, prettyValue
    -- * parse into JSON Value
  , parseValue, parseValue', 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
  ) where

import           Data.Char
import           Data.Functor.Compose
import           Data.Functor.Const
import           Data.Functor.Identity
import           Data.Functor.Product
import           Data.Functor.Sum
import qualified Data.Monoid                    as Monoid
import           Data.Proxy                     (Proxy (..))
import           Data.Scientific                (toBoundedInteger)
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           Foreign.C.Types
import           System.Exit                    (ExitCode(..))
import qualified Z.Data.Builder                 as B
import           Z.Data.JSON.Base
import qualified Z.Data.JSON.Builder            as JB
import qualified Z.Data.Parser                  as P
import qualified Z.Data.Text                    as T

-- $use
--
-- This module is intended to be used qualified, e.g.
--
-- > import qualified Z.Data.JSON as JSON
-- > import           Z.Data.JSON ((.:), JSON(..))
--
-- The easiest way to use the library is to define target data type, deriving
-- 'GHC.Generics.Generic' and 'JSON' instances, which provides:
--
--   * 'fromValue' to convert 'Value' to Haskell values.
--   * 'toValue' to convert Haskell values to 'Value'.
--   * 'encodeJSON' to directly write Haskell value into JSON bytes.
--
-- For example,
--
-- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies #-}
-- >
-- > import GHC.Generics (Generic)
-- > import qualified Z.Data.Builder as Builder
-- > import qualified Z.Data.JSON as JSON
-- > import qualified Z.Data.Text as T
-- >
-- > data Person = Person {name :: T.Text, age :: Int}
-- >     deriving (Show, Generic)
-- >     deriving anyclass (JSON.JSON)
--
-- We can now encode & decode with 'T.Text' like so:
--
-- >>> JSON.encodeText (Person{ name="Alice", age=16 })
-- "{\"age\":16,\"name\":\"Alice\"}"
-- >>> JSON.decodeText' "{\"age\":16,\"name\":\"Alice\"}" :: Either JSON.DecodeError Person
-- Right (Person {age = 16, name = "Alice"})
--
-- The 'GHC.Generics.Generic' instances convert(encode) Haskell data with following rules:
--
--   * Constructors without payloads are encoded as JSON String, @data T = A | B@ are encoded as @\"A\"@ or @\"B\"@.
--   * Single constructor are ingored if there're payloads, @data T = T ...@,  @T@ is ingored:
--
--     * Records are encoded as JSON object. @data T = T{k1 :: .., k2 :: ..}@ are encoded as @{\"k1\":...,\"k2\":...}@.
--     * Plain product are encoded as JSON array. @data T = T t1 t2@ are encoded as "[x1,x2]".
--     * Single field plain product are encoded as it is, i.e. @data T = T t@ are encoded as \"x\" just like its payload.
--
--   * Multiple constructors are convert to single key JSON object if there're payloads:
--
--     * Records are encoded as JSON object like above. @data T = A | B {k1 :: .., k2 :: ..}@ are encoded as
--         @{\"B\":{\"k1\":...,\"k2\":...}}@ in @B .. ..@ case, or @\"A\"@ in @A@ case.
--     * Plain product are similar to above, wrappered by an outer single-key object layer marking which constructor.
--
-- These rules apply to user defined ADTs, but some built-in instances have
-- different behaviour, namely:
--
--   * @Maybe a@ are encoded as JSON @null@ in 'Nothing' case, or directly encoded to its payload in 'Just' case.
--   * @[a]@ are encoded to JSON array, @[Char]@ are encoded into JSON string.
--   * 'NonEmpty', 'Vector', 'PrimVector', 'HashSet', 'FlatSet', 'FlatIntSet' are also encoded to JSON array.
--   * 'Bytes' are encoded into JSON text using base64 encoding.
--   * 'HashMap', 'FlatMap', 'FlatIntMap' are encoded to JSON object.

-- $custom-settings
--
-- There're some modifying options if you providing a custom 'Settings', which
-- allow you to modify field name or constructor name, but please /DO NOT/
-- produce control characters during your modification, since we assume field
-- labels and constructor name won't contain them, thus we can save an extra
-- escaping pass. To use custom 'Settings' just write:
--
-- > data T = T {fooT :: Int, barT :: [Int]} deriving Generic
-- > instance JSON.ToValue T where
-- >     -- You can omit following definition if you don't need to change settings
-- >     toValue = JSON.gToValue JSON.defaultSettings{ JSON.fieldFmt = JSON.snakeCase } . from
-- >
-- > -- define this instances if you need fast JSON encoding(without convert to JSON.Value first)
-- > instance JSON.EncodeJSON T where
-- >     -- You can omit following definition if you don't need to change settings
-- >     encodeJSON = JSON.gEncodeJSON JSON.defaultSettings{ JSON.fieldFmt = JSON.snakeCase } . from
--
-- >>> JSON.toValue (T 0 [1,2,3])
-- Object [("foo_t",Number 0.0),("bar_t",Array [Number 1.0,Number 2.0,Number 3.0])]
--
-- $manually-instance
--
-- You can write 'JSON' instances by hand if the 'Generic' based one doesn't suit you.
-- Here is an example similar to aeson's.
--
-- @
-- import qualified Z.Data.Text          as T
-- import qualified Z.Data.Vector        as V
-- import qualified Z.Data.Builder       as B
-- import qualified Z.Data.JSON          as JSON
-- import           Z.Data.JSON          ((.:), (.=), (.!), JSON(..))
--
-- data Person = Person { name :: T.Text , age  :: Int } deriving Show
--
-- instance JSON Person where
--     fromValue = JSON.withFlatMapR \"Person\" $ \\ v -> Person
--                     \<$\> v .: \"name\"
--                     \<*\> v .: \"age\"
--
--     toValue (Person n a) = JSON.object [\"name\" .= n, \"age\" .= a]
--
--     encodeJSON (Person n a) = JSON.object' $ (\"name\" .! n <> \"age\" .! a)
-- @
--
-- >>> toValue (Person "Joe" 12)
-- Object [("name",String "Joe"),("age",Number 12.0)]
-- >>> JSON.convert' @Person . JSON.Object $ V.pack [("name",JSON.String "Joe"),("age",JSON.Number 12.0)]
-- Right (Person {name = "Joe", age = 12})
-- >>> JSON.encodeText (Person "Joe" 12)
-- "{"name":"Joe","age":12}"
--
-- The 'Value' type is different from aeson's one in that we use @Vector (Text, Value)@ to represent JSON objects, thus
-- we can choose different strategies on key duplication, the lookup map type, etc. so instead of a single 'withObject',
-- we provide 'withHashMap', 'withHashMapR', 'withFlatMap' and 'withFlatMapR' which use different lookup map type, and different key order piority. Most of time 'FlatMap' is faster than 'HashMap' since we only use the lookup map once, the cost of constructing a 'HashMap' is higher. If you want to directly working on key-values, 'withKeyValues' provide key-values vector access.
--
-- There're some useful tools to help write encoding code in "Z.Data.JSON.Builder" module, such as JSON string escaping tool, etc.
--
-- If you don't particularly care for fast encoding, you can also use 'toValue' together with value builder, the overhead is usually very small.


-- | Snake casing a pascal cased constructor name or camel cased field name, words are always lower cased and separated by an
-- underscore.
snakeCase :: String -> T.Text
{-# INLINE snakeCase #-}
snakeCase :: String -> Text
snakeCase = Char -> String -> Text
symbCase Char
'_'

-- | Train casing a pascal cased constructor name or camel cased field name, words are always lower cased and separated by
-- a hyphen.
trainCase :: String -> T.Text
{-# INLINE trainCase #-}
trainCase :: String -> Text
trainCase = Char -> String -> Text
symbCase Char
'-'

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

symbCase :: Char -> String -> T.Text
{-# INLINE symbCase #-}
symbCase :: Char -> String -> Text
symbCase Char
sym =  String -> Text
T.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
applyFirst Char -> Char
toLower
  where
    go :: String -> String
go []                       = []
    go (Char
x:String
xs) | Char -> Bool
isUpper Char
x = Char
sym Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
              | Bool
otherwise = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs

    applyFirst :: (a -> a) -> [a] -> [a]
applyFirst a -> a
_ []     = []
    applyFirst a -> a
f (a
x:[a]
xs) = a -> a
f a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

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

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 ()
B.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

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

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

-- | 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";

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

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)