{-|
Module      : Z.Data.MessagePack.Base
Description : Fast MessagePack serialization/deserialization
Copyright   : (c) Dong Han, 2020
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 'MessagePack' instance.

-}

module Z.Data.MessagePack.Base
  ( -- * MessagePack Class
    MessagePack(..), Value(..), defaultSettings, Settings(..)
    -- * Encode & Decode
  , decode, decode', decodeChunks, decodeChunks', encode, encodeChunks
  , DecodeError, P.ParseError
    -- * parse into MessagePack Value
  , MV.parseValue, MV.parseValue', MV.parseValueChunks, MV.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           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 qualified Data.Foldable                  as Foldable
import           Data.Hashable
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           GHC.Int
import           GHC.Exts
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, coefficient, base10Exponent)
import qualified Data.Scientific                as Sci
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 (..), systemToUTCTime, utcToSystemTime)
import           Data.Version                   (Version, parseVersion)
import           Data.Word
import           Foreign.C.Types
import           GHC.Exts                       (Proxy#, proxy#)
import           GHC.Generics
import           GHC.Natural
import           GHC.Integer.GMP.Internals
import           System.Exit
import           Text.ParserCombinators.ReadP   (readP_to_S)
import qualified Z.Data.Array                   as A
import qualified Z.Data.Builder                 as B
import           Z.Data.Generics.Utils
import           Z.Data.JSON.Converter
import qualified Z.Data.MessagePack.Builder     as MB
import           Z.Data.MessagePack.Value       (Value (..))
import qualified Z.Data.MessagePack.Value       as MV
import qualified Z.Data.Parser                  as P
import qualified Z.Data.Parser.Numeric          as P
import qualified Z.Data.Text.Base               as T
import qualified Z.Data.Text                    as T
import qualified Z.Data.Text.Print              as T
import qualified Z.Data.Vector.Base             as V
import qualified Z.Data.Vector.Extra            as V
import qualified Z.Data.Vector.FlatIntMap       as FIM
import qualified Z.Data.Vector.FlatIntSet       as FIS
import qualified Z.Data.Vector.FlatMap          as FM
import qualified Z.Data.Vector.FlatSet          as FS

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

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

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

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

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

-- 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 MessagePack doc, trailing bytes are not allowed.
decode' :: MessagePack a => V.Bytes -> Either DecodeError a
{-# INLINE decode' #-}
decode' :: Bytes -> Either DecodeError a
decode' Bytes
bs = case Parser Value -> Bytes -> Either ParseError Value
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (Parser Value
MV.value Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) Bytes
bs of
    Left ParseError
pErr -> DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ParseError -> DecodeError
forall a b. a -> Either a b
Left ParseError
pErr)
    Right Value
v -> case Value -> Either ConvertError a
forall a. MessagePack a => Value -> Either ConvertError a
convertValue Value
v of
        Left ConvertError
cErr -> DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (ConvertError -> DecodeError
forall a b. b -> Either a b
Right ConvertError
cErr)
        Right a
r   -> a -> Either DecodeError a
forall a b. b -> Either a b
Right a
r

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

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

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

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

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

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

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

-- | Produce an error message like @converting XXX failed, expected XXX, encountered XXX@.
typeMismatch :: T.Text     -- ^ The name of the type you are trying to convert.
             -> T.Text     -- ^ The MessagePack value type you expecting to meet.
             -> Value      -- ^ The actual value encountered.
             -> Converter a
{-# INLINE typeMismatch #-}
typeMismatch :: Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
expected Value
v =
    Text -> Converter a
forall a. Text -> Converter a
fail' (Text -> Converter a) -> Text -> Converter a
forall a b. (a -> b) -> a -> b
$ ParseError -> Text
T.concat [Text
"converting ", Text
name, Text
" failed, expected ", Text
expected, Text
", encountered ", Text
actual]
  where
    actual :: Text
actual = case Value
v of
        Value
Nil      ->  Text
"Nil"
        Bool Bool
_   ->  Text
"Bool"
        Int  Int64
_   ->  Text
"Int"
        Float Float
_  ->  Text
"Float"
        Double Double
_ ->  Text
"Double"
        Str Text
_    ->  Text
"Str"
        Bin Bytes
_    ->  Text
"Bin"
        Array Vector Value
_  ->  Text
"Array"
        Map Vector (Value, Value)
_    ->  Text
"Map"
        Ext Word8
_ Bytes
_  ->  Text
"Ext"

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

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

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

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

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

-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number
-- when @value@ is a 'Ext' @0x00@, 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 (Str "oops")
-- > -- Error: "converting MyType failed, expected Ext 0x00/0x01, but encountered Str"
withScientific :: T.Text -> (Scientific -> Converter a) -> Value ->  Converter a
{-# INLINE withScientific #-}
withScientific :: Text -> (Scientific -> Converter a) -> Value -> Converter a
withScientific Text
name Scientific -> Converter a
f (Ext Word8
tag Bytes
x) | Word8
tag Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x01 = do
    case Parser Value -> Bytes -> (Bytes, Either ParseError Value)
forall a. Parser a -> Bytes -> (Bytes, Either ParseError a)
P.parse Parser Value
MV.value Bytes
x of
        (Bytes
rest, Right (Int Int64
d)) ->  Int -> Bytes -> Converter a
mkSci (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
d) Bytes
rest
        (Bytes
_, Right Value
v) -> Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(exponent)") Text
"Int" Value
v
        (Bytes
_, Left ParseError
e) -> Text -> Converter a
forall a. Text -> Converter a
fail' (ParseError -> Text
T.concat [Text
"converting ", Text
name, Text
" failed: ", ParseError -> Text
forall a. Print a => a -> Text
T.toText ParseError
e])
  where
    mkSci :: Int -> Bytes -> Converter a
mkSci !Int
e (V.PrimVector (A.PrimArray ByteArray#
ba#) (I# Int#
s#) (I# Int#
l#)) =
        let !c :: Integer
c = ByteArray# -> Word# -> Word# -> Int# -> Integer
importIntegerFromByteArray ByteArray#
ba# (Int# -> Word#
int2Word# Int#
s#) (Int# -> Word#
int2Word# Int#
l#) Int#
1#
        in if Word8
tag Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x01 then Scientific -> Converter a
f (Scientific -> Scientific
forall a. Num a => a -> a
negate (Integer -> Int -> Scientific
Sci.scientific Integer
c Int
e))
                          else Scientific -> Converter a
f (Integer -> Int -> Scientific
Sci.scientific Integer
c Int
e)
withScientific Text
name Scientific -> Converter a
_ Value
v = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Ext 0x00/0x01" Value
v

withSystemTime :: T.Text -> (SystemTime -> Converter a) -> Value ->  Converter a
{-# INLINE withSystemTime #-}
withSystemTime :: Text -> (SystemTime -> Converter a) -> Value -> Converter a
withSystemTime Text
name SystemTime -> Converter a
f (Ext Word8
tag Bytes
x) | Word8
tag Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xFF = do
    case Parser SystemTime -> Bytes -> Either ParseError SystemTime
forall a. Parser a -> Bytes -> Either ParseError a
P.parse' (do
        !Word32
ns <- Unaligned (BE Word32) => Parser Word32
forall a. Unaligned (BE a) => Parser a
P.decodePrimBE @Word32
        !Int64
s <- Parser Int64
forall a. Unaligned (BE a) => Parser a
P.decodePrimBE
        SystemTime -> Parser SystemTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Word32 -> SystemTime
MkSystemTime Int64
s (Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ns))) Bytes
x of
            Left ParseError
e -> Text -> Converter a
forall a. Text -> Converter a
fail' (Text
"parse Ext 0xFF timestamp format failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall a. Print a => a -> Text
T.toText ParseError
e)
            Right SystemTime
v -> SystemTime -> Converter a
f SystemTime
v
withSystemTime Text
name SystemTime -> Converter a
_ Value
v = Text -> Text -> Value -> Converter a
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
name Text
"Ext 0x00" Value
v

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

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

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

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

-- | Retrieve the value associated with the given key of an 'Map'.
-- 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.
(.:) :: (MessagePack a) => FM.FlatMap Value Value -> T.Text -> Converter a
{-# INLINE (.:) #-}
.: :: FlatMap Value Value -> Text -> Converter a
(.:) = (Value -> Converter a)
-> FlatMap Value Value -> Text -> Converter a
forall a.
(Value -> Converter a)
-> FlatMap Value Value -> Text -> Converter a
convertField Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue

-- | Retrieve the value associated with the given key of an 'Map'. The
-- result is 'Nothing' if the key is not present or if its value is 'Nil',
-- 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.
(.:?) :: (MessagePack a) => FM.FlatMap Value Value -> T.Text -> Converter (Maybe a)
{-# INLINE (.:?) #-}
.:? :: FlatMap Value Value -> Text -> Converter (Maybe a)
(.:?) = (Value -> Converter a)
-> FlatMap Value Value -> Text -> Converter (Maybe a)
forall a.
(Value -> Converter a)
-> FlatMap Value Value -> Text -> Converter (Maybe a)
convertFieldMaybe Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue

-- | Retrieve the value associated with the given key of an 'Map'.
-- 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 'Nil' the same as any
-- other MessagePack value, instead of interpreting it as 'Nothing'.
(.:!) :: (MessagePack a) => FM.FlatMap Value Value -> T.Text -> Converter (Maybe a)
{-# INLINE (.:!) #-}
.:! :: FlatMap Value Value -> Text -> Converter (Maybe a)
(.:!) = (Value -> Converter a)
-> FlatMap Value Value -> Text -> Converter (Maybe a)
forall a.
(Value -> Converter a)
-> FlatMap Value Value -> Text -> Converter (Maybe a)
convertFieldMaybe' Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue

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

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

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

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

-- | A newtype for 'B.Builder', whose semigroup's instance is to connect kv builder and sum kv length.
data KVItem = KVItem {-# UNPACK #-} !Int (B.Builder ())

instance Semigroup KVItem where
    {-# INLINE (<>) #-}
    KVItem Int
siza Builder ()
a <> :: KVItem -> KVItem -> KVItem
<> KVItem Int
sizb Builder ()
b = Int -> Builder () -> KVItem
KVItem (Int
sizaInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sizb) (Builder ()
a Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
b)

-- | Connect key and value to a 'KVItem' using 'B.colon', key will be escaped.
(.!) :: MessagePack v => T.Text -> v -> KVItem
{-# INLINE (.!) #-}
Text
k .! :: Text -> v -> KVItem
.! v
v = Int -> Builder () -> KVItem
KVItem Int
1 (Text -> Builder ()
MB.str Text
k Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> v -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack v
v)
infixr 8 .!

-- | Write map header and 'KVItem's.
object' :: KVItem -> B.Builder ()
{-# INLINE object' #-}
object' :: KVItem -> Builder ()
object' (KVItem Int
siz Builder ()
kvb) = Int -> Builder ()
MB.mapHeader Int
siz Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder ()
kvb

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

-- | Alias for @Map . pack@.
object :: [(Value, Value)] -> Value
{-# INLINE object #-}
object :: [(Value, Value)] -> Value
object = Vector (Value, Value) -> Value
Map (Vector (Value, Value) -> Value)
-> ([(Value, Value)] -> Vector (Value, Value))
-> [(Value, Value)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Value, Value)] -> Vector (Value, Value)
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack

--------------------------------------------------------------------------------
-- | Generic encode/decode Settings
--
data Settings = Settings
    { Settings -> String -> Text
fieldFmt  :: String -> T.Text -- ^ format field labels
    , Settings -> String -> Text
constrFmt :: String -> T.Text -- ^ format constructor names
    , Settings -> Bool
missingKeyAsNil :: Bool      -- ^ take missing field as 'Nil'?
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

--------------------------------------------------------------------------------
-- MessagePack
--------------------------------------------------------------------------------

class GEncodeMessagePack f where
    gEncodeMessagePack :: Settings -> f a -> B.Builder ()

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

instance (GEncodeMessagePack f, Selector (MetaSel (Just l) u ss ds)) => GEncodeMessagePack (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gEncodeMessagePack #-}
    gEncodeMessagePack :: Settings -> S1 ('MetaSel ('Just l) u ss ds) f a -> Builder ()
gEncodeMessagePack Settings
s m1 :: S1 ('MetaSel ('Just l) u ss ds) f a
m1@(M1 f a
x) = (Text -> Builder ()
MB.str (Text -> Builder ()) -> (String -> Text) -> String -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> String -> Text
fieldFmt Settings
s (String -> Builder ()) -> String -> Builder ()
forall a b. (a -> b) -> a -> b
$ S1 ('MetaSel ('Just l) u ss ds) f a -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName S1 ('MetaSel ('Just l) u ss ds) f a
m1) Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Settings -> f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeMessagePack f =>
Settings -> f a -> Builder ()
gEncodeMessagePack Settings
s f a
x

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

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

instance MessagePack a => GEncodeMessagePack (K1 i a) where
    {-# INLINE gEncodeMessagePack #-}
    gEncodeMessagePack :: Settings -> K1 i a a -> Builder ()
gEncodeMessagePack Settings
_ (K1 a
x) = a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack a
x

class GAddProductSize (f :: * -> *) where
    gAddProductSize :: Proxy# f -> Int -> B.Builder ()

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

instance GAddProductSize (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gAddProductSize #-}
    gAddProductSize :: Proxy# (S1 ('MetaSel 'Nothing u ss ds) f) -> Int -> Builder ()
gAddProductSize Proxy# (S1 ('MetaSel 'Nothing u ss ds) f)
_ = Int -> Builder ()
MB.arrayHeader

instance GAddProductSize (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gAddProductSize #-}
    gAddProductSize :: Proxy# (S1 ('MetaSel ('Just l) u ss ds) f) -> Int -> Builder ()
gAddProductSize Proxy# (S1 ('MetaSel ('Just l) u ss ds) f)
_ = Int -> Builder ()
MB.mapHeader

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

class GConstrEncodeMessagePack f where
    gConstrEncodeMessagePack :: Bool -> Settings -> f a -> B.Builder ()

instance GConstrEncodeMessagePack V1 where
    {-# INLINE gConstrEncodeMessagePack #-}
    gConstrEncodeMessagePack :: Bool -> Settings -> V1 a -> Builder ()
gConstrEncodeMessagePack Bool
_ Settings
_ V1 a
_ = String -> Builder ()
forall a. HasCallStack => String -> a
error String
"Z.Data.MessagePack.Base: empty data type"

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

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

-- | Constructor with a single payload
instance (Constructor c, GEncodeMessagePack (S1 (MetaSel Nothing u ss ds) f))
    => GConstrEncodeMessagePack (C1 c (S1 (MetaSel Nothing u ss ds) f)) where
    {-# INLINE gConstrEncodeMessagePack #-}
    gConstrEncodeMessagePack :: Bool
-> Settings
-> C1 c (S1 ('MetaSel 'Nothing u ss ds) f) a
-> Builder ()
gConstrEncodeMessagePack Bool
False Settings
s (M1 S1 ('MetaSel 'Nothing u ss ds) f a
x) = do
        Settings -> S1 ('MetaSel 'Nothing u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeMessagePack f =>
Settings -> f a -> Builder ()
gEncodeMessagePack Settings
s S1 ('MetaSel 'Nothing u ss ds) f a
x
    gConstrEncodeMessagePack Bool
True Settings
s (M1 S1 ('MetaSel 'Nothing u ss ds) f a
x) = do
        Int -> Builder ()
MB.mapHeader Int
1
        Text -> Builder ()
MB.str (Settings -> String -> Text
constrFmt Settings
s (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName @c Any c Any Any
forall a. HasCallStack => a
undefined)
        Settings -> S1 ('MetaSel 'Nothing u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeMessagePack f =>
Settings -> f a -> Builder ()
gEncodeMessagePack Settings
s S1 ('MetaSel 'Nothing u ss ds) f a
x

instance (Constructor c, GEncodeMessagePack (S1 (MetaSel (Just l) u ss ds) f))
    => GConstrEncodeMessagePack (C1 c (S1 (MetaSel (Just l) u ss ds) f)) where
    {-# INLINE gConstrEncodeMessagePack #-}
    gConstrEncodeMessagePack :: Bool
-> Settings
-> C1 c (S1 ('MetaSel ('Just l) u ss ds) f) a
-> Builder ()
gConstrEncodeMessagePack Bool
False Settings
s (M1 S1 ('MetaSel ('Just l) u ss ds) f a
x) = do
        Int -> Builder ()
MB.mapHeader Int
1
        Settings -> S1 ('MetaSel ('Just l) u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeMessagePack f =>
Settings -> f a -> Builder ()
gEncodeMessagePack Settings
s S1 ('MetaSel ('Just l) u ss ds) f a
x
    gConstrEncodeMessagePack Bool
True Settings
s (M1 S1 ('MetaSel ('Just l) u ss ds) f a
x) = do
        Int -> Builder ()
MB.mapHeader Int
1
        Text -> Builder ()
MB.str (Settings -> String -> Text
constrFmt Settings
s (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName @c Any c Any Any
forall a. HasCallStack => a
undefined)
        Int -> Builder ()
MB.mapHeader Int
1
        Settings -> S1 ('MetaSel ('Just l) u ss ds) f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeMessagePack f =>
Settings -> f a -> Builder ()
gEncodeMessagePack Settings
s S1 ('MetaSel ('Just l) u ss ds) f a
x

-- | Constructor with multiple payloads
instance (GEncodeMessagePack (a :*: b), GAddProductSize (a :*: b), ProductSize (a :*: b), Constructor c)
    => GConstrEncodeMessagePack (C1 c (a :*: b)) where
    {-# INLINE gConstrEncodeMessagePack #-}
    gConstrEncodeMessagePack :: Bool -> Settings -> C1 c (a :*: b) a -> Builder ()
gConstrEncodeMessagePack Bool
False Settings
s (M1 (:*:) a b a
x) = do
        Proxy# (a :*: b) -> Int -> Builder ()
forall (f :: * -> *).
GAddProductSize f =>
Proxy# f -> Int -> Builder ()
gAddProductSize (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)) (Proxy# (a :*: b) -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)))
        Settings -> (:*:) a b a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeMessagePack f =>
Settings -> f a -> Builder ()
gEncodeMessagePack Settings
s (:*:) a b a
x
    gConstrEncodeMessagePack Bool
True Settings
s (M1 (:*:) a b a
x) = do
        Int -> Builder ()
MB.mapHeader Int
1
        Text -> Builder ()
MB.str (Settings -> String -> Text
constrFmt Settings
s (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Any c Any Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName @c @_ @_ @_ Any c Any Any
forall a. HasCallStack => a
undefined)
        Proxy# (a :*: b) -> Int -> Builder ()
forall (f :: * -> *).
GAddProductSize f =>
Proxy# f -> Int -> Builder ()
gAddProductSize (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)) (Proxy# (a :*: b) -> Int
forall (f :: * -> *). KnownNat (PSize f) => Proxy# f -> Int
productSize (Proxy# (a :*: b)
forall k (a :: k). Proxy# a
proxy# :: Proxy# (a :*: b)))
        Settings -> (:*:) a b a -> Builder ()
forall k (f :: k -> *) (a :: k).
GEncodeMessagePack f =>
Settings -> f a -> Builder ()
gEncodeMessagePack Settings
s (:*:) a b a
x

--------------------------------------------------------------------------------
-- Data types
instance GConstrEncodeMessagePack f => GEncodeMessagePack (D1 c f) where
    {-# INLINE gEncodeMessagePack #-}
    gEncodeMessagePack :: Settings -> D1 c f a -> Builder ()
gEncodeMessagePack Settings
s (M1 f a
x) = Bool -> Settings -> f a -> Builder ()
forall k (f :: k -> *) (a :: k).
GConstrEncodeMessagePack f =>
Bool -> Settings -> f a -> Builder ()
gConstrEncodeMessagePack Bool
False Settings
s f a
x

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

--------------------------------------------------------------------------------
-- Built-in Instances
--------------------------------------------------------------------------------
-- | Use 'Nil' as @Proxy a@
instance MessagePack (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
fromNil Text
"Proxy" Proxy a
forall k (t :: k). Proxy t
Proxy;
    {-# INLINE toValue #-}; toValue :: Proxy a -> Value
toValue Proxy a
_ = Value
Nil;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack :: Proxy a -> Builder ()
encodeMessagePack Proxy a
_ = Builder ()
MB.nil;

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

instance MessagePack T.Text   where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Text
fromValue = Text -> (Text -> Converter Text) -> Value -> Converter Text
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withStr Text
"Text" Text -> Converter Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Text -> Value
toValue = Text -> Value
Str;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack :: Text -> Builder ()
encodeMessagePack = Text -> Builder ()
MB.str;

-- | Note this instance doesn't reject large input
instance MessagePack Scientific where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Scientific
fromValue = Text
-> (Scientific -> Converter Scientific)
-> Value
-> Converter Scientific
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withScientific Text
"Data.Scientific.Scientific" Scientific -> Converter Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE toValue #-}
    toValue :: Scientific -> Value
toValue Scientific
x = Integer -> Int64 -> Value
MB.scientificValue (Scientific -> Integer
coefficient Scientific
x) (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Scientific -> Int
base10Exponent Scientific
x)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Scientific -> Builder ()
encodeMessagePack Scientific
x = Integer -> Int64 -> Builder ()
MB.scientific (Scientific -> Integer
coefficient Scientific
x) (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Scientific -> Int
base10Exponent Scientific
x)

-- | default instance prefer later key
instance (Ord a, MessagePack a, MessagePack b) => MessagePack (FM.FlatMap a b) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (FlatMap a b)
fromValue = Text
-> (FlatMap Value Value -> Converter (FlatMap a b))
-> Value
-> Converter (FlatMap a b)
forall a.
Text
-> (FlatMap Value Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"Z.Data.Vector.FlatMap.FlatMap" ((FlatMap Value Value -> Converter (FlatMap a b))
 -> Value -> Converter (FlatMap a b))
-> (FlatMap Value Value -> Converter (FlatMap a b))
-> Value
-> Converter (FlatMap a b)
forall a b. (a -> b) -> a -> b
$ \ FlatMap Value Value
m ->
        let kvs :: [(Value, Value)]
kvs = Vector (Value, Value) -> [(Value, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack (FlatMap Value Value -> Vector (Value, Value)
forall k v. FlatMap k v -> Vector (k, v)
FM.sortedKeyValues FlatMap Value Value
m)
        in [(a, b)] -> FlatMap a b
forall k v. Ord k => [(k, v)] -> FlatMap k v
FM.packR ([(a, b)] -> FlatMap a b)
-> Converter [(a, b)] -> Converter (FlatMap a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Value, Value)]
-> ((Value, Value) -> Converter (a, b)) -> Converter [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Value, Value)]
kvs (((Value, Value) -> Converter (a, b)) -> Converter [(a, b)])
-> ((Value, Value) -> Converter (a, b)) -> Converter [(a, b)]
forall a b. (a -> b) -> a -> b
$ \ (Value
k, Value
v) -> do
            a
k' <- Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue Value
k
            b
v' <- Value -> Converter b
forall a. MessagePack a => Value -> Converter a
fromValue Value
v Converter b -> PathElement -> Converter b
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key (Value -> Text
forall a. Print a => a -> Text
T.toText Value
k)
            (a, b) -> Converter (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
k', b
v'))
    {-# INLINE toValue #-}
    toValue :: FlatMap a b -> Value
toValue = Vector (Value, Value) -> Value
Map (Vector (Value, Value) -> Value)
-> (FlatMap a b -> Vector (Value, Value)) -> FlatMap a b -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (Value, Value))
-> Vector (a, b) -> Vector (Value, Value)
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map (\ (a
k, b
v) -> (a -> Value
forall a. MessagePack a => a -> Value
toValue a
k, b -> Value
forall a. MessagePack a => a -> Value
toValue b
v)) (Vector (a, b) -> Vector (Value, Value))
-> (FlatMap a b -> Vector (a, b))
-> FlatMap a b
-> Vector (Value, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatMap a b -> Vector (a, b)
forall k v. FlatMap k v -> Vector (k, v)
FM.sortedKeyValues
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: FlatMap a b -> Builder ()
encodeMessagePack = (a -> Builder ())
-> (b -> Builder ()) -> Vector (a, b) -> Builder ()
forall a b.
(a -> Builder ())
-> (b -> Builder ()) -> Vector (a, b) -> Builder ()
MB.map a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack b -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack (Vector (a, b) -> Builder ())
-> (FlatMap a b -> Vector (a, b)) -> FlatMap a b -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatMap a b -> Vector (a, b)
forall k v. FlatMap k v -> Vector (k, v)
FM.sortedKeyValues

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

-- | default instance prefer later key
instance (Eq a, Hashable a, MessagePack a, MessagePack b) => MessagePack (HM.HashMap a b) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (HashMap a b)
fromValue = Text
-> (Vector (Value, Value) -> Converter (HashMap a b))
-> Value
-> Converter (HashMap a b)
forall a.
Text
-> (Vector (Value, Value) -> Converter a) -> Value -> Converter a
withKeyValues Text
"Data.HashMap.HashMap" ((Vector (Value, Value) -> Converter (HashMap a b))
 -> Value -> Converter (HashMap a b))
-> (Vector (Value, Value) -> Converter (HashMap a b))
-> Value
-> Converter (HashMap a b)
forall a b. (a -> b) -> a -> b
$ \ Vector (Value, Value)
kvs ->
        [(a, b)] -> HashMap a b
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(a, b)] -> HashMap a b)
-> Converter [(a, b)] -> Converter (HashMap a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Value, Value)]
-> ((Value, Value) -> Converter (a, b)) -> Converter [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Vector (Value, Value) -> [(Value, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Value, Value)
kvs) (((Value, Value) -> Converter (a, b)) -> Converter [(a, b)])
-> ((Value, Value) -> Converter (a, b)) -> Converter [(a, b)]
forall a b. (a -> b) -> a -> b
$ \ (Value
k, Value
v) -> do
            !a
k' <- Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue Value
k
            !b
v' <- Value -> Converter b
forall a. MessagePack a => Value -> Converter a
fromValue Value
v Converter b -> PathElement -> Converter b
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key (Value -> Text
forall a. Print a => a -> Text
T.toText Value
k)
            (a, b) -> Converter (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
k', b
v'))
    {-# INLINE toValue #-}
    toValue :: HashMap a b -> Value
toValue = Vector (Value, Value) -> Value
Map (Vector (Value, Value) -> Value)
-> (HashMap a b -> Vector (Value, Value)) -> HashMap a b -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Value, Value)] -> Vector (Value, Value)
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack ([(Value, Value)] -> Vector (Value, Value))
-> (HashMap a b -> [(Value, Value)])
-> HashMap a b
-> Vector (Value, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (Value, Value)) -> [(a, b)] -> [(Value, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a
k,b
v) -> (a -> Value
forall a. MessagePack a => a -> Value
toValue a
k, b -> Value
forall a. MessagePack a => a -> Value
toValue b
v)) ([(a, b)] -> [(Value, Value)])
-> (HashMap a b -> [(a, b)]) -> HashMap a b -> [(Value, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap a b -> [(a, b)]
forall k v. HashMap k v -> [(k, v)]
HM.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: HashMap a b -> Builder ()
encodeMessagePack = (a -> Builder ()) -> (b -> Builder ()) -> [(a, b)] -> Builder ()
forall a b.
(a -> Builder ()) -> (b -> Builder ()) -> [(a, b)] -> Builder ()
MB.map' a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack b -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack ([(a, b)] -> Builder ())
-> (HashMap a b -> [(a, b)]) -> HashMap a b -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap a b -> [(a, b)]
forall k v. HashMap k v -> [(k, v)]
HM.toList

instance (Ord a, MessagePack a, MessagePack b) => MessagePack (M.Map a b) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Map a b)
fromValue = Text
-> (Vector (Value, Value) -> Converter (Map a b))
-> Value
-> Converter (Map a b)
forall a.
Text
-> (Vector (Value, Value) -> Converter a) -> Value -> Converter a
withKeyValues Text
"Data.HashMap.HashMap" ((Vector (Value, Value) -> Converter (Map a b))
 -> Value -> Converter (Map a b))
-> (Vector (Value, Value) -> Converter (Map a b))
-> Value
-> Converter (Map a b)
forall a b. (a -> b) -> a -> b
$ \ Vector (Value, Value)
kvs ->
        [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, b)] -> Map a b) -> Converter [(a, b)] -> Converter (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Value, Value)]
-> ((Value, Value) -> Converter (a, b)) -> Converter [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Vector (Value, Value) -> [(Value, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Value, Value)
kvs) (((Value, Value) -> Converter (a, b)) -> Converter [(a, b)])
-> ((Value, Value) -> Converter (a, b)) -> Converter [(a, b)]
forall a b. (a -> b) -> a -> b
$ \ (Value
k, Value
v) -> do
            !a
k' <- Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue Value
k
            !b
v' <- Value -> Converter b
forall a. MessagePack a => Value -> Converter a
fromValue Value
v Converter b -> PathElement -> Converter b
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key (Value -> Text
forall a. Print a => a -> Text
T.toText Value
k)
            (a, b) -> Converter (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
k', b
v'))
    {-# INLINE toValue #-}
    toValue :: Map a b -> Value
toValue = Vector (Value, Value) -> Value
Map (Vector (Value, Value) -> Value)
-> (Map a b -> Vector (Value, Value)) -> Map a b -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Value, Value)] -> Vector (Value, Value)
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack ([(Value, Value)] -> Vector (Value, Value))
-> (Map a b -> [(Value, Value)])
-> Map a b
-> Vector (Value, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (Value, Value)) -> [(a, b)] -> [(Value, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a
k,b
v) -> (a -> Value
forall a. MessagePack a => a -> Value
toValue a
k, b -> Value
forall a. MessagePack a => a -> Value
toValue b
v)) ([(a, b)] -> [(Value, Value)])
-> (Map a b -> [(a, b)]) -> Map a b -> [(Value, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
M.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Map a b -> Builder ()
encodeMessagePack = (a -> Builder ()) -> (b -> Builder ()) -> [(a, b)] -> Builder ()
forall a b.
(a -> Builder ()) -> (b -> Builder ()) -> [(a, b)] -> Builder ()
MB.map' a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack b -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack ([(a, b)] -> Builder ())
-> (Map a b -> [(a, b)]) -> Map a b -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
M.toList

instance MessagePack a => MessagePack (FIM.FlatIntMap a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (FlatIntMap a)
fromValue = Text
-> (FlatMap Value Value -> Converter (FlatIntMap a))
-> Value
-> Converter (FlatIntMap a)
forall a.
Text
-> (FlatMap Value Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"Z.Data.Vector.FlatIntMap.FlatIntMap" ((FlatMap Value Value -> Converter (FlatIntMap a))
 -> Value -> Converter (FlatIntMap a))
-> (FlatMap Value Value -> Converter (FlatIntMap a))
-> Value
-> Converter (FlatIntMap a)
forall a b. (a -> b) -> a -> b
$ \ FlatMap Value Value
m ->
        let kvs :: Vector (Value, Value)
kvs = FlatMap Value Value -> Vector (Value, Value)
forall k v. FlatMap k v -> Vector (k, v)
FM.sortedKeyValues FlatMap Value Value
m
        in Vector (IPair a) -> FlatIntMap a
forall v. Vector (IPair v) -> FlatIntMap v
FIM.packVectorR (Vector (IPair a) -> FlatIntMap a)
-> Converter (Vector (IPair a)) -> Converter (FlatIntMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Vector (Value, Value)
-> ((Value, Value) -> Converter (IPair a))
-> Converter (Vector (IPair a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Vector (Value, Value)
kvs (((Value, Value) -> Converter (IPair a))
 -> Converter (Vector (IPair a)))
-> ((Value, Value) -> Converter (IPair a))
-> Converter (Vector (IPair a))
forall a b. (a -> b) -> a -> b
$ \ (Value
k, Value
v) -> do
            case Value
k of
                Int Int64
k' -> do
                    a
v' <- Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key (Value -> Text
forall a. Print a => a -> Text
T.toText Value
k)
                    IPair a -> Converter (IPair a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a -> IPair a
forall a. Int -> a -> IPair a
V.IPair (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
k') a
v')
                Value
_ -> Text -> Converter (IPair a)
forall a. Text -> Converter a
fail' (Text
"converting Z.Data.Vector.FlatIntMap.FlatIntMap failed, unexpected key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Value -> Text
forall a. Print a => a -> Text
T.toText Value
k)))
    {-# INLINE toValue #-}
    toValue :: FlatIntMap a -> Value
toValue = Vector (Value, Value) -> Value
Map (Vector (Value, Value) -> Value)
-> (FlatIntMap a -> Vector (Value, Value)) -> FlatIntMap a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IPair a -> (Value, Value))
-> Vector (IPair a) -> Vector (Value, Value)
forall (u :: * -> *) (v :: * -> *) a b.
(Vec u a, Vec v b) =>
(a -> b) -> u a -> v b
V.map' IPair a -> (Value, Value)
forall a. MessagePack a => IPair a -> (Value, Value)
toKV (Vector (IPair a) -> Vector (Value, Value))
-> (FlatIntMap a -> Vector (IPair a))
-> FlatIntMap a
-> Vector (Value, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatIntMap a -> Vector (IPair a)
forall v. FlatIntMap v -> Vector (IPair v)
FIM.sortedKeyValues
      where toKV :: IPair a -> (Value, Value)
toKV (V.IPair Int
i a
x) = let !k :: Value
k = Int64 -> Value
Int (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
                                     !v :: Value
v = a -> Value
forall a. MessagePack a => a -> Value
toValue a
x
                                 in (Value
k, Value
v)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: FlatIntMap a -> Builder ()
encodeMessagePack FlatIntMap a
m = do
        let kvs :: Vector (IPair a)
kvs = FlatIntMap a -> Vector (IPair a)
forall v. FlatIntMap v -> Vector (IPair v)
FIM.sortedKeyValues FlatIntMap a
m
        Int -> Builder ()
MB.mapHeader (Vector (IPair a) -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Vector (IPair a)
kvs)
        (IPair a -> Builder ()) -> Vector (IPair a) -> Builder ()
forall (v :: * -> *) a (f :: * -> *) b.
(Vec v a, Applicative f) =>
(a -> f b) -> v a -> f ()
V.traverseVec_ (\ (V.IPair Int
k a
v) -> Int64 -> Builder ()
MB.int (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack a
v) Vector (IPair a)
kvs

instance MessagePack a => MessagePack (IM.IntMap a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (IntMap a)
fromValue = Text
-> (Vector (Value, Value) -> Converter (IntMap a))
-> Value
-> Converter (IntMap a)
forall a.
Text
-> (Vector (Value, Value) -> Converter a) -> Value -> Converter a
withKeyValues Text
"Data.IntMap.IntMap" ((Vector (Value, Value) -> Converter (IntMap a))
 -> Value -> Converter (IntMap a))
-> (Vector (Value, Value) -> Converter (IntMap a))
-> Value
-> Converter (IntMap a)
forall a b. (a -> b) -> a -> b
$ \ Vector (Value, Value)
kvs ->
        [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, a)] -> IntMap a)
-> Converter [(Int, a)] -> Converter (IntMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Value, Value)]
-> ((Value, Value) -> Converter (Int, a)) -> Converter [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Vector (Value, Value) -> [(Value, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Value, Value)
kvs) (((Value, Value) -> Converter (Int, a)) -> Converter [(Int, a)])
-> ((Value, Value) -> Converter (Int, a)) -> Converter [(Int, a)]
forall a b. (a -> b) -> a -> b
$ \ (Value
k, Value
v) -> do
            case Value
k of
                Int Int64
k' -> do
                    a
v' <- Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Text -> PathElement
Key (Value -> Text
forall a. Print a => a -> Text
T.toText Value
k)
                    (Int, a) -> Converter (Int, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
k', a
v')
                Value
_ -> Text -> Converter (Int, a)
forall a. Text -> Converter a
fail' (Text
"converting Data.IntMap.IntMap failed, unexpected key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Value -> Text
forall a. Print a => a -> Text
T.toText Value
k)))
    {-# INLINE toValue #-}
    toValue :: IntMap a -> Value
toValue = Vector (Value, Value) -> Value
Map (Vector (Value, Value) -> Value)
-> (IntMap a -> Vector (Value, Value)) -> IntMap a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Value, Value)] -> Vector (Value, Value)
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack ([(Value, Value)] -> Vector (Value, Value))
-> (IntMap a -> [(Value, Value)])
-> IntMap a
-> Vector (Value, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> (Value, Value)) -> [(Int, a)] -> [(Value, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> (Value, Value)
forall a a. (MessagePack a, Integral a) => (a, a) -> (Value, Value)
toKV ([(Int, a)] -> [(Value, Value)])
-> (IntMap a -> [(Int, a)]) -> IntMap a -> [(Value, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IM.toList
      where toKV :: (a, a) -> (Value, Value)
toKV (a
i, a
x) = let !k :: Value
k = Int64 -> Value
Int (a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i)
                              !v :: Value
v = a -> Value
forall a. MessagePack a => a -> Value
toValue a
x
                          in (Value
k, Value
v)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: IntMap a -> Builder ()
encodeMessagePack IntMap a
m = do
        Int -> Builder ()
MB.mapHeader (IntMap a -> Int
forall a. IntMap a -> Int
IM.size IntMap a
m)
        ((Int, a) -> Builder ()) -> [(Int, a)] -> Builder ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (Int
k, a
v) -> Int64 -> Builder ()
MB.int (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack a
v) (IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap a
m)

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

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

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

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

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

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

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

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

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

instance MessagePack A.ByteArray where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter ByteArray
fromValue = Text
-> (Bytes -> Converter ByteArray) -> Value -> Converter ByteArray
forall a. Text -> (Bytes -> Converter a) -> Value -> Converter a
withBin Text
"ByteArray" ((Bytes -> Converter ByteArray) -> Value -> Converter ByteArray)
-> (Bytes -> Converter ByteArray) -> Value -> Converter ByteArray
forall a b. (a -> b) -> a -> b
$ \ (V.PrimVector pa :: PrimArray Word8
pa@(A.PrimArray ByteArray#
ba#) Int
s Int
l) ->
        if PrimArray Word8 -> Int
forall (arr :: * -> *) a. Arr arr a => arr a -> Int
A.sizeofArr PrimArray Word8
pa Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l Bool -> Bool -> Bool
&& Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then ByteArray -> Converter ByteArray
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteArray# -> ByteArray
A.ByteArray ByteArray#
ba#)
        else ByteArray -> Converter ByteArray
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteArray -> Converter ByteArray)
-> ByteArray -> Converter ByteArray
forall a b. (a -> b) -> a -> b
$! ByteArray -> Int -> Int -> ByteArray
A.cloneByteArray (ByteArray# -> ByteArray
A.ByteArray ByteArray#
ba#) Int
s Int
l
    {-# INLINE toValue #-}
    toValue :: ByteArray -> Value
toValue (A.ByteArray ByteArray#
ba#) = Bytes -> Value
Bin (IArray PrimVector Word8 -> Bytes
forall (v :: * -> *) a. Vec v a => IArray v a -> v a
V.arrVec (ByteArray# -> PrimArray Word8
forall a. ByteArray# -> PrimArray a
A.PrimArray ByteArray#
ba#))
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: ByteArray -> Builder ()
encodeMessagePack (A.ByteArray ByteArray#
ba#) = Bytes -> Builder ()
MB.bin (IArray PrimVector Word8 -> Bytes
forall (v :: * -> *) a. Vec v a => IArray v a -> v a
V.arrVec (ByteArray# -> PrimArray Word8
forall a. ByteArray# -> PrimArray a
A.PrimArray ByteArray#
ba#))

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

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

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

instance MessagePack a => MessagePack [a] where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter [a]
fromValue = Text -> (Vector Value -> Converter [a]) -> Value -> Converter [a]
forall a.
Text -> (Vector Value -> Converter a) -> Value -> Converter a
withArray Text
"[a]" ((Vector Value -> Converter [a]) -> Value -> Converter [a])
-> (Vector Value -> Converter [a]) -> Value -> Converter [a]
forall a b. (a -> b) -> a -> b
$ \ Vector Value
vs ->
        (Int -> Value -> Converter a) -> [Int] -> [Value] -> Converter [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ Int
k Value
v -> Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue Value
v Converter a -> PathElement -> Converter a
forall a. Converter a -> PathElement -> Converter a
<?> Int -> PathElement
Index Int
k) [Int
0..] (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
    {-# INLINE toValue #-}
    toValue :: [a] -> Value
toValue = Vector Value -> Value
Array (Vector Value -> Value) -> ([a] -> Vector Value) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.pack ([Value] -> Vector Value)
-> ([a] -> [Value]) -> [a] -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. MessagePack a => a -> Value
toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: [a] -> Builder ()
encodeMessagePack = (a -> Builder ()) -> [a] -> Builder ()
forall a. (a -> Builder ()) -> [a] -> Builder ()
MB.array' a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack

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

instance MessagePack Bool where
    {-# INLINE fromValue #-}; fromValue :: Value -> Converter Bool
fromValue = Text -> (Bool -> Converter Bool) -> Value -> Converter Bool
forall a. Text -> (Bool -> Converter a) -> Value -> Converter a
withBool Text
"Bool" Bool -> Converter Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure;
    {-# INLINE toValue #-}; toValue :: Bool -> Value
toValue = Bool -> Value
Bool;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack :: Bool -> Builder ()
encodeMessagePack = Bool -> Builder ()
MB.bool

instance MessagePack Char where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Char
fromValue = Text -> (Text -> Converter Char) -> Value -> Converter Char
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withStr Text
"Char" ((Text -> Converter Char) -> Value -> Converter Char)
-> (Text -> Converter Char) -> Value -> Converter Char
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        if (Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
        then Char -> Converter Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Char
T.head Text
t)
        else Text -> Converter Char
forall a. Text -> Converter a
fail' (ParseError -> Text
T.concat [Text
"converting Char failed, expected a string of length 1"])
    {-# INLINE toValue #-}
    toValue :: Char -> Value
toValue = Text -> Value
Str (Text -> Value) -> (Char -> Text) -> Char -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Char -> Builder ()
encodeMessagePack = Text -> Builder ()
MB.str (Text -> Builder ()) -> (Char -> Text) -> Char -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton

instance MessagePack Double where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Double
fromValue (Float Float
d) = Double -> Converter Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Converter Double) -> Double -> Converter Double
forall a b. (a -> b) -> a -> b
$! Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
d
    fromValue (Double Double
d) = Double -> Converter Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
d
    fromValue Value
v = Text -> Text -> Value -> Converter Double
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
"Double" Text
"Float or Double" Value
v
    {-# INLINE toValue #-}; toValue :: Double -> Value
toValue = Double -> Value
Double;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack :: Double -> Builder ()
encodeMessagePack = Double -> Builder ()
MB.double;

instance MessagePack Float  where
    {-# INLINE fromValue #-};
    fromValue :: Value -> Converter Float
fromValue (Float Float
d) = Float -> Converter Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
d
    fromValue (Double Double
d) = Float -> Converter Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Converter Float) -> Float -> Converter Float
forall a b. (a -> b) -> a -> b
$! Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d
    fromValue Value
v = Text -> Text -> Value -> Converter Float
forall a. Text -> Text -> Value -> Converter a
typeMismatch Text
"Float" Text
"Float or Double" Value
v
    {-# INLINE toValue #-}; toValue :: Float -> Value
toValue = Float -> Value
Float;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack :: Float -> Builder ()
encodeMessagePack = Float -> Builder ()
MB.float;

#define INT_MessagePack_INSTANCE(typ) \
    instance MessagePack typ where \
        {-# INLINE fromValue #-}; \
            fromValue (Int x) = pure $! fromIntegral x; \
            fromValue v = typeMismatch "##typ##" "Int" v; \
        {-# INLINE toValue #-}; toValue = Int . fromIntegral; \
        {-# INLINE encodeMessagePack #-}; encodeMessagePack = MB.int . fromIntegral;
INT_MessagePack_INSTANCE(Int   )
INT_MessagePack_INSTANCE(Int8  )
INT_MessagePack_INSTANCE(Int16 )
INT_MessagePack_INSTANCE(Int32 )
INT_MessagePack_INSTANCE(Int64 )
INT_MessagePack_INSTANCE(Word  )
INT_MessagePack_INSTANCE(Word8 )
INT_MessagePack_INSTANCE(Word16)
INT_MessagePack_INSTANCE(Word32)
INT_MessagePack_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 MessagePack Integer where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Integer
fromValue = Text
-> (Scientific -> Converter Integer) -> Value -> Converter Integer
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
"Integer" ((Scientific -> Converter Integer) -> Value -> Converter Integer)
-> (Scientific -> Converter Integer) -> Value -> Converter Integer
forall a b. (a -> b) -> a -> b
$ \ Scientific
n ->
        case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Sci.floatingOrInteger Scientific
n :: Either Double Integer of
            Right Integer
x -> Integer -> Converter Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
            Left Double
_  -> Text -> Converter Integer
forall a. Text -> Converter a
fail' (Text -> Converter Integer)
-> (Builder () -> Text) -> Builder () -> Converter Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter Integer)
-> Builder () -> Converter Integer
forall a b. (a -> b) -> a -> b
$ do
                Builder ()
"converting Integer failed, unexpected floating number "
                Scientific -> Builder ()
T.scientific Scientific
n
    {-# INLINE toValue #-}
    toValue :: Integer -> Value
toValue Integer
x = Integer -> Int64 -> Value
MB.scientificValue Integer
x Int64
0
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Integer -> Builder ()
encodeMessagePack Integer
x = Integer -> Int64 -> Builder ()
MB.scientific Integer
x Int64
0

-- | 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 MessagePack Natural where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Natural
fromValue = Text
-> (Scientific -> Converter Natural) -> Value -> Converter Natural
forall a.
Text -> (Scientific -> Converter a) -> Value -> Converter a
withBoundedScientific Text
"Natural" ((Scientific -> Converter Natural) -> Value -> Converter Natural)
-> (Scientific -> Converter Natural) -> Value -> Converter Natural
forall a b. (a -> b) -> a -> b
$ \ Scientific
n ->
        if Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
< Scientific
0
        then Text -> Converter Natural
forall a. Text -> Converter a
fail' (Text -> Converter Natural)
-> (Builder () -> Text) -> Builder () -> Converter Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter Natural)
-> Builder () -> Converter Natural
forall a b. (a -> b) -> a -> b
$ do
                Builder ()
"converting Natural failed, unexpected negative number "
                Scientific -> Builder ()
T.scientific Scientific
n
        else case Scientific -> Either Double Natural
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Sci.floatingOrInteger Scientific
n :: Either Double Natural of
            Right Natural
x -> Natural -> Converter Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
x
            Left Double
_  -> Text -> Converter Natural
forall a. Text -> Converter a
fail' (Text -> Converter Natural)
-> (Builder () -> Text) -> Builder () -> Converter Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText (Builder () -> Converter Natural)
-> Builder () -> Converter Natural
forall a b. (a -> b) -> a -> b
$ do
                Builder ()
"converting Natural failed, unexpected floating number "
                Scientific -> Builder ()
T.scientific Scientific
n
    {-# INLINE toValue #-}
    toValue :: Natural -> Value
toValue Natural
x = Integer -> Int64 -> Value
MB.scientificValue (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x) Int64
0
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Natural -> Builder ()
encodeMessagePack Natural
x = Integer -> Int64 -> Builder ()
MB.scientific (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x) Int64
0

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

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

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

instance MessagePack Version where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Version
fromValue = Text -> (Text -> Converter Version) -> Value -> Converter Version
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
withStr Text
"Version" ([(Version, String)] -> Converter Version
forall (f :: * -> *) a a. MonadFail f => [(a, [a])] -> f a
go ([(Version, String)] -> Converter Version)
-> (Text -> [(Version, String)]) -> Text -> Converter Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion ReadS Version -> (Text -> String) -> Text -> [(Version, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
      where
        go :: [(a, [a])] -> f a
go [(a
v,[])] = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
        go ((a, [a])
_ : [(a, [a])]
xs) = [(a, [a])] -> f a
go [(a, [a])]
xs
        go [(a, [a])]
_        = String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"converting Version failed"
    {-# INLINE toValue #-}
    toValue :: Version -> Value
toValue = Text -> Value
Str (Text -> Value) -> (Version -> Text) -> Version -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Version -> String) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
forall a. Show a => a -> String
show
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Version -> Builder ()
encodeMessagePack = String -> Builder ()
MB.str' (String -> Builder ())
-> (Version -> String) -> Version -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
forall a. Show a => a -> String
show

instance MessagePack a => MessagePack (Maybe a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Maybe a)
fromValue Value
Nil = Maybe a -> Converter (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    fromValue Value
v    = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Converter a -> Converter (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Converter a
forall a. MessagePack a => Value -> Converter a
fromValue Value
v
    {-# INLINE toValue #-}
    toValue :: Maybe a -> Value
toValue Maybe a
Nothing  = Value
Nil
    toValue (Just a
x) = a -> Value
forall a. MessagePack a => a -> Value
toValue a
x
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Maybe a -> Builder ()
encodeMessagePack Maybe a
Nothing  = Builder ()
MB.nil
    encodeMessagePack (Just a
x) = a -> Builder ()
forall a. MessagePack a => a -> Builder ()
encodeMessagePack a
x

instance (MessagePack a, Integral a) => MessagePack (Ratio a) where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter (Ratio a)
fromValue = Text
-> (FlatMap Value Value -> Converter (Ratio a))
-> Value
-> Converter (Ratio a)
forall a.
Text
-> (FlatMap Value Value -> Converter a) -> Value -> Converter a
withFlatMapR Text
"Rational" ((FlatMap Value Value -> Converter (Ratio a))
 -> Value -> Converter (Ratio a))
-> (FlatMap Value Value -> Converter (Ratio a))
-> Value
-> Converter (Ratio a)
forall a b. (a -> b) -> a -> b
$ \FlatMap Value Value
obj -> do
        !a
n <- FlatMap Value Value
obj FlatMap Value Value -> Text -> Converter a
forall a.
MessagePack a =>
FlatMap Value Value -> Text -> Converter a
.: Text
"numerator"
        !a
d <- FlatMap Value Value
obj FlatMap Value Value -> Text -> Converter a
forall a.
MessagePack a =>
FlatMap Value Value -> Text -> Converter a
.: Text
"denominator"
        if a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
        then Text -> Converter (Ratio a)
forall a. Text -> Converter a
fail' Text
"Ratio denominator was 0"
        else Ratio a -> Converter (Ratio a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
d)
    {-# INLINE toValue #-}
    toValue :: Ratio a -> Value
toValue Ratio a
x = [(Value, Value)] -> Value
object [ Text
"numerator" Text -> a -> (Value, Value)
forall v. MessagePack v => Text -> v -> (Value, Value)
.= (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
x) , Text
"denominator" Text -> a -> (Value, Value)
forall v. MessagePack v => Text -> v -> (Value, Value)
.= (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
x) ]
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack :: Ratio a -> Builder ()
encodeMessagePack Ratio a
x = KVItem -> Builder ()
object' ( Text
"numerator" Text -> a -> KVItem
forall v. MessagePack v => Text -> v -> KVItem
.! (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
x) KVItem -> KVItem -> KVItem
forall a. Semigroup a => a -> a -> a
<> Text
"denominator" Text -> a -> KVItem
forall v. MessagePack v => Text -> v -> KVItem
.! (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
x) )

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

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

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