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

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

This module provides an interface similar to "Z.Data.JSON", to work with MessagePack binary format.

  * @Maybe a@ convert to 'Nil' in 'Nothing' case, and @a@ in 'Just' case.
  * Use 'Int64'(signed) or 'Word64'(unsigned) type to marshall int type format, smaller types will sliently truncate when overflow.
  * Use 'Double' to marshall float type format, 'Float' may lost precision.
  * Use 'Scientific' to marshall 'Ext' @0x00\/0x01@ type.
  * Use 'SystemTime' to marshall 'Ext' @0xFF@ type.
  * Record's field label are preserved.

  * We use MessagePack extension type -1 to encode\/decode 'SystemTime' and 'UTCTime':

        +--------+--------+--------+-----------------------------------+------------------------------+
        |  0xc7  |   12   |   -1   |nanoseconds in 32-bit unsigned int | seconds in 64-bit signed int |
        +--------+--------+--------+-----------------------------------+------------------------------+

  * We deliberately use ext type 0x00(positive) and 0x01(negative) to represent large numbers('Integer', 'Scientific', 'Fixed', 'DiffTime'...):

        +--------+--------+--------+-----------------------------------------+---------------------------------------+
        |  0xc7  |XXXXXXXX|  0x00  | base10 exponent(MessagePack int format) | coefficient(big endian 256-base limbs |
        +--------+--------+--------+-----------------------------------------+---------------------------------------+

        Use a MessagePack implementation supporting ext type to marshall it, result value is coefficient * (10 ^ exponent).

The easiest way to use the library is to define target data type, deriving 'GHC.Generics.Generic' and 'MessagePack' instances, e.g.

@
{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies #-}

import GHC.Generics (Generic)
import qualified Z.Data.MessagePack as MessagePack
import qualified Z.Data.Text as T

data Person = Person {name :: T.Text, age :: Int}
    deriving (Show, Generic)
    deriving anyclass (MessagePack.MessagePack)

> MessagePack.encode Person{ name=\"Alice\", age=16 }
> [130,164,110,97,109,101,165,65,108,105,99,101,163,97,103,101,16]
@

MessagePack is a schemaless format, which means the encoded data can be recovered into some form('Value' in haskell case)
without providing data definition, e.g. the data encoded above:

> [130,   164,   110,   97,   109,   101,   165,   65,   108,   105,   99,   101,   163,   97,   103,   101,   16]
>  0x82   0xA4   'n'    'a'   'm'    'e'    0xA5   'A'   'l'    'i'    'c'   'e'    0xA3   'a'   'g'    'e'    int
>  map    str                               str                                     str                        16
>  2kvs   4bytes                            5bytes                                  3bytes


This property makes it suitable for passing data across language boundary, e.g. from a static typed language to a dynamic one, at the cost of a lower space efficiency(i.e. type tag and field label).

-}

module Z.Data.MessagePack
  ( -- * MessagePack Class
    MessagePack(..), Value(..), defaultSettings, Settings(..), JSON.snakeCase, JSON.trainCase
    -- * Encode & Decode
  , readMessagePackFile, writeMessagePackFile
  , decode, decode', decodeChunks, encode, encodeChunks
  , DecodeError, ParseError
    -- * parse into MessagePack Value
  , parseValue, parseValue', parseValueChunks, parseValueChunks'
  -- * Generic FromValue, ToValue & EncodeMessagePack
  , gToValue, gFromValue, gEncodeMessagePack
  -- * Convert 'Value' to Haskell data
  , convertValue, Converter(..), fail', (<?>), prependContext
  , PathElement(..), ConvertError(..)
  , typeMismatch, fromNil, withBool
  , withStr, withBin, withArray, withKeyValues, withFlatMap, withFlatMapR
  , (.:), (.:?), (.:!), 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                (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 (..), utcToSystemTime, systemToUTCTime)
import           Data.Version                   (Version(versionBranch), makeVersion)
import           Foreign.C.Types
import           System.Exit                    (ExitCode(..))
import qualified Z.Data.Builder                 as B
import           Z.Data.MessagePack.Base
import qualified Z.Data.MessagePack.Builder     as MB
import qualified Z.Data.JSON                    as JSON
import qualified Z.Data.Parser                  as P
import qualified Z.Data.Text                    as T
import           Z.Data.CBytes            (CBytes)
import           Z.IO
import qualified Z.IO.FileSystem as FS

-- | Decode a 'MessagePack' instance from file.
readMessagePackFile :: (HasCallStack, MessagePack a) => CBytes -> IO a
readMessagePackFile :: CBytes -> IO a
readMessagePackFile CBytes
p = Text -> Either DecodeError a -> IO a
forall e a. (HasCallStack, Print e) => Text -> Either e a -> IO a
unwrap Text
"EPARSE" (Either DecodeError a -> IO a)
-> (Bytes -> Either DecodeError a) -> Bytes -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Either DecodeError a
forall a. MessagePack a => Bytes -> Either DecodeError a
decode' (Bytes -> IO a) -> IO Bytes -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => CBytes -> IO Bytes
CBytes -> IO Bytes
FS.readFile CBytes
p

-- | Encode a 'MessagePack' instance to file.
writeMessagePackFile :: (HasCallStack, MessagePack a) => CBytes -> a -> IO ()
writeMessagePackFile :: CBytes -> a -> IO ()
writeMessagePackFile CBytes
p a
x = HasCallStack => CBytes -> Bytes -> IO ()
CBytes -> Bytes -> IO ()
FS.writeFile CBytes
p (a -> Bytes
forall a. MessagePack a => a -> Bytes
encode a
x)

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

instance MessagePack ExitCode where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter ExitCode
fromValue (Str Text
"ExitSuccess") = ExitCode -> Converter ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
    fromValue (Int Int64
x) = ExitCode -> Converter ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
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
Str Text
"ExitSuccess"
    toValue (ExitFailure Int
n) = Int64 -> Value
Int (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

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

-- | Only round trip 'versionBranch' as MessagePack array.
instance MessagePack 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. MessagePack a => Value -> Converter a
fromValue Value
v
    {-# INLINE toValue #-}
    toValue :: Version -> Value
toValue = [Int] -> Value
forall a. MessagePack a => a -> Value
toValue ([Int] -> Value) -> (Version -> [Int]) -> Version -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionBranch
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Version -> Builder ()
encodeMessagePack = [Int] -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack ([Int] -> Builder ())
-> (Version -> [Int]) -> Version -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionBranch

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

-- | MessagePack extension type @Ext 0xFF@
instance MessagePack UTCTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter UTCTime
fromValue = Text
-> (SystemTime -> Converter UTCTime) -> Value -> Converter UTCTime
forall a.
Text -> (SystemTime -> Converter a) -> Value -> Converter a
withSystemTime Text
"UTCTime" ((SystemTime -> Converter UTCTime) -> Value -> Converter UTCTime)
-> (SystemTime -> Converter UTCTime) -> Value -> Converter UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> Converter UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> Converter UTCTime)
-> (SystemTime -> UTCTime) -> SystemTime -> Converter UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemTime -> UTCTime
systemToUTCTime
    {-# INLINE toValue #-}
    toValue :: UTCTime -> Value
toValue UTCTime
t = let (MkSystemTime Int64
s Word32
ns) = UTCTime -> SystemTime
utcToSystemTime UTCTime
t in Int64 -> Int32 -> Value
MB.timestampValue Int64
s (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ns)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: UTCTime -> Builder ()
encodeMessagePack UTCTime
t = let (MkSystemTime Int64
s Word32
ns) = UTCTime -> SystemTime
utcToSystemTime UTCTime
t in Int64 -> Int32 -> Builder ()
MB.timestamp Int64
s (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ns)

-- | MessagePack extension type @Ext 0xFF@
instance MessagePack SystemTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter SystemTime
fromValue = Text
-> (SystemTime -> Converter SystemTime)
-> Value
-> Converter SystemTime
forall a.
Text -> (SystemTime -> Converter a) -> Value -> Converter a
withSystemTime Text
"UTCTime" ((SystemTime -> Converter SystemTime)
 -> Value -> Converter SystemTime)
-> (SystemTime -> Converter SystemTime)
-> Value
-> Converter SystemTime
forall a b. (a -> b) -> a -> b
$ SystemTime -> Converter SystemTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE toValue #-}
    toValue :: SystemTime -> Value
toValue (MkSystemTime Int64
s Word32
ns) = Int64 -> Int32 -> Value
MB.timestampValue Int64
s (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ns)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: SystemTime -> Builder ()
encodeMessagePack (MkSystemTime Int64
s Word32
ns) = Int64 -> Int32 -> Builder ()
MB.timestamp Int64
s (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ns)

-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance MessagePack 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
withStr 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
Str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (ZonedTime -> Builder ()
B.zonedTime ZonedTime
t))
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: ZonedTime -> Builder ()
encodeMessagePack ZonedTime
t = Text -> Builder ()
MB.str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (ZonedTime -> Builder ()
B.zonedTime ZonedTime
t))

-- | @YYYY-MM-DD@
instance MessagePack 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
withStr 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
Str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Day -> Builder ()
B.day Day
t))
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Day -> Builder ()
encodeMessagePack Day
t = Text -> Builder ()
MB.str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Day -> Builder ()
B.day Day
t))

-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
instance MessagePack 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
withStr 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
Str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (LocalTime -> Builder ()
B.localTime LocalTime
t))
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: LocalTime -> Builder ()
encodeMessagePack LocalTime
t = Text -> Builder ()
MB.str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (LocalTime -> Builder ()
B.localTime LocalTime
t))

-- | @HH:MM:SS.SSS@
instance MessagePack 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
withStr 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
Str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (TimeOfDay -> Builder ()
B.timeOfDay TimeOfDay
t))
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: TimeOfDay -> Builder ()
encodeMessagePack TimeOfDay
t = Text -> Builder ()
MB.str (Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (TimeOfDay -> Builder ()
B.timeOfDay TimeOfDay
t))

-- | 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 MessagePack 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 = MessagePack Scientific => Scientific -> Value
forall a. MessagePack a => a -> Value
toValue @Scientific (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 encodeMessagePack #-}
    encodeMessagePack :: NominalDiffTime -> Builder ()
encodeMessagePack = MessagePack Scientific => Scientific -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack @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 MessagePack 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 = MessagePack Scientific => Scientific -> Value
forall a. MessagePack a => a -> Value
toValue @Scientific (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 encodeMessagePack #-}
    encodeMessagePack :: DiffTime -> Builder ()
encodeMessagePack = MessagePack Scientific => Scientific -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack @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

instance MessagePack CalendarDiffTime where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter CalendarDiffTime
fromValue = Text
-> (FlatMap Value Value -> Converter CalendarDiffTime)
-> Value
-> Converter CalendarDiffTime
forall a.
Text
-> (FlatMap Value Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"CalendarDiffTime" ((FlatMap Value Value -> Converter CalendarDiffTime)
 -> Value -> Converter CalendarDiffTime)
-> (FlatMap Value Value -> Converter CalendarDiffTime)
-> Value
-> Converter CalendarDiffTime
forall a b. (a -> b) -> a -> b
$ \ FlatMap Value 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 Value Value
v FlatMap Value Value -> Text -> Converter Integer
forall a.
MessagePack a =>
FlatMap Value 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 Value Value
v FlatMap Value Value -> Text -> Converter NominalDiffTime
forall a.
MessagePack a =>
FlatMap Value Value -> Text -> Converter a
.: Text
"time"
    {-# INLINE toValue #-}
    toValue :: CalendarDiffTime -> Value
toValue (CalendarDiffTime Integer
m NominalDiffTime
nt) = [(Value, Value)] -> Value
object [ Text
"months" Text -> Integer -> (Value, Value)
forall v. MessagePack v => Text -> v -> (Value, Value)
.= Integer
m , Text
"time" Text -> NominalDiffTime -> (Value, Value)
forall v. MessagePack v => Text -> v -> (Value, Value)
.= NominalDiffTime
nt ]
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: CalendarDiffTime -> Builder ()
encodeMessagePack (CalendarDiffTime Integer
m NominalDiffTime
nt) = KVItem -> Builder ()
object' (Text
"months" Text -> Integer -> KVItem
forall v. MessagePack v => Text -> v -> KVItem
.! Integer
m KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"time" Text -> NominalDiffTime -> KVItem
forall v. MessagePack v => Text -> v -> KVItem
.! NominalDiffTime
nt)

instance MessagePack CalendarDiffDays where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter CalendarDiffDays
fromValue = Text
-> (FlatMap Value Value -> Converter CalendarDiffDays)
-> Value
-> Converter CalendarDiffDays
forall a.
Text
-> (FlatMap Value Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"CalendarDiffDays" ((FlatMap Value Value -> Converter CalendarDiffDays)
 -> Value -> Converter CalendarDiffDays)
-> (FlatMap Value Value -> Converter CalendarDiffDays)
-> Value
-> Converter CalendarDiffDays
forall a b. (a -> b) -> a -> b
$ \ FlatMap Value 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 Value Value
v FlatMap Value Value -> Text -> Converter Integer
forall a.
MessagePack a =>
FlatMap Value 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 Value Value
v FlatMap Value Value -> Text -> Converter Integer
forall a.
MessagePack a =>
FlatMap Value Value -> Text -> Converter a
.: Text
"days"
    {-# INLINE toValue #-}
    toValue :: CalendarDiffDays -> Value
toValue (CalendarDiffDays Integer
m Integer
d) = [(Value, Value)] -> Value
object [Text
"months" Text -> Integer -> (Value, Value)
forall v. MessagePack v => Text -> v -> (Value, Value)
.= Integer
m, Text
"days" Text -> Integer -> (Value, Value)
forall v. MessagePack v => Text -> v -> (Value, Value)
.= Integer
d]
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: CalendarDiffDays -> Builder ()
encodeMessagePack (CalendarDiffDays Integer
m Integer
d) = KVItem -> Builder ()
object' (Text
"months" Text -> Integer -> KVItem
forall v. MessagePack v => Text -> v -> KVItem
.! Integer
m KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"days" Text -> Integer -> KVItem
forall v. MessagePack v => Text -> v -> KVItem
.! Integer
d)

instance MessagePack DayOfWeek where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter DayOfWeek
fromValue (Str Text
"monday"   ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Monday
    fromValue (Str Text
"tuesday"  ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Tuesday
    fromValue (Str Text
"wednesday") = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Wednesday
    fromValue (Str Text
"thursday" ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Thursday
    fromValue (Str Text
"friday"   ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Friday
    fromValue (Str Text
"saturday" ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Saturday
    fromValue (Str Text
"sunday"   ) = DayOfWeek -> Converter DayOfWeek
forall (f :: * -> *) a. Applicative f => a -> f a
pure DayOfWeek
Sunday
    fromValue (Str 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
Str Text
"monday"
    toValue DayOfWeek
Tuesday   = Text -> Value
Str Text
"tuesday"
    toValue DayOfWeek
Wednesday = Text -> Value
Str Text
"wednesday"
    toValue DayOfWeek
Thursday  = Text -> Value
Str Text
"thursday"
    toValue DayOfWeek
Friday    = Text -> Value
Str Text
"friday"
    toValue DayOfWeek
Saturday  = Text -> Value
Str Text
"saturday"
    toValue DayOfWeek
Sunday    = Text -> Value
Str Text
"sunday"
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: DayOfWeek -> Builder ()
encodeMessagePack DayOfWeek
Monday    = Text -> Builder ()
MB.str Text
"monday"
    encodeMessagePack DayOfWeek
Tuesday   = Text -> Builder ()
MB.str Text
"tuesday"
    encodeMessagePack DayOfWeek
Wednesday = Text -> Builder ()
MB.str Text
"wednesday"
    encodeMessagePack DayOfWeek
Thursday  = Text -> Builder ()
MB.str Text
"thursday"
    encodeMessagePack DayOfWeek
Friday    = Text -> Builder ()
MB.str Text
"friday"
    encodeMessagePack DayOfWeek
Saturday  = Text -> Builder ()
MB.str Text
"saturday"
    encodeMessagePack DayOfWeek
Sunday    = Text -> Builder ()
MB.str Text
"sunday"


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

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

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

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

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

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

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