{-|
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 various tools to help user define 'MessagePack' instance, please import `Z.Data.MessagePack` to get more instances.

-}

module Z.Data.MessagePack.Base
  ( -- * MessagePack Class
    MessagePack(..), Value(..), defaultSettings, Settings(..)
    -- * Encode & Decode
  , decode, decode', decodeChunks, encode, encodeChunks
  , DecodeError, P.ParseError, P.ParseChunks
    -- * 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
  , withBoundedScientific, withSystemTime
  , (.:), (.:?), (.:!), 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 qualified Z.Data.CBytes                  as CBytes
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 v = to <$> gFromValue defaultSettings v
    {-# INLINABLE fromValue #-}

    toValue :: a -> Value
    default toValue :: (Generic a, GToValue (Rep a)) => a -> Value
    toValue = gToValue defaultSettings . from
    {-# INLINABLE toValue #-}

    encodeMessagePack :: a -> B.Builder ()
    default encodeMessagePack :: (Generic a, GEncodeMessagePack (Rep a)) => a -> B.Builder ()
    encodeMessagePack = gEncodeMessagePack defaultSettings . 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' bs = case P.parse' (MV.value <* P.endOfInput) bs of
    Left pErr -> Left (Left pErr)
    Right v -> case convertValue v of
        Left cErr -> Left (Right cErr)
        Right r   -> Right r

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

-- | Decode 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 mb bs = do
    mr <- P.parseChunks MV.value mb bs
    case mr of
        (bs', Left pErr) -> pure (bs', Left (Left pErr))
        (bs', Right v) ->
            case convertValue v of
                Left cErr -> pure (bs', Left (Right cErr))
                Right r   -> pure (bs', Right r)

-- | Directly encode data to MessagePack bytes.
encode :: MessagePack a => a -> V.Bytes
{-# INLINE encode #-}
encode = B.build . encodeMessagePack

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

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

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

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

fromNil :: T.Text -> a -> Value -> Converter a
{-# INLINE fromNil #-}
fromNil _ a Nil = pure a
fromNil c _ v    = typeMismatch c "Nil" v

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

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

withBin :: T.Text -> (V.Bytes -> Converter a) -> Value -> Converter a
{-# INLINE withBin #-}
withBin _    f (Bin x) = f x
withBin name _ v       = typeMismatch name "Bin" 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 name f v = withScientific name f' v
  where
    f' x | e <= 1024 = f x
         | otherwise = fail' . B.unsafeBuildText $ do
            "converting "
            T.text name
            " failed, found a number with exponent "
            T.int e
            ", but it must not be greater than 1024"
      where e = base10Exponent x

-- | @'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 name f (Ext tag x) | tag <= 0x01 = do
    case P.parse MV.value x of
        (rest, Right (Int d)) ->  mkSci (fromIntegral d) rest
        (_, Right v) -> typeMismatch (name <> "(exponent)") "Int" v
        (_, Left e) -> fail' (T.concat ["converting ", name, " failed: ", T.toText e])
  where
    mkSci !e (V.PrimVector (A.PrimArray ba#) (I# s#) (I# l#)) =
        let !c = importIntegerFromByteArray ba# (int2Word# s#) (int2Word# l#) 1#
        in if tag == 0x01 then f (negate (Sci.scientific c e))
                          else f (Sci.scientific c e)
withScientific name _ v = typeMismatch name "Ext 0x00/0x01" v

withSystemTime :: T.Text -> (SystemTime -> Converter a) -> Value ->  Converter a
{-# INLINE withSystemTime #-}
withSystemTime name f (Ext tag x) | tag == 0xFF = do
    case P.parse' (do
        !ns <- P.decodePrimBE @Word32
        !s <- P.decodePrimBE
        pure (MkSystemTime s (fromIntegral ns))) x of
            Left e -> fail' ("parse Ext 0xFF timestamp format failed: " <> T.toText e)
            Right v -> f v
withSystemTime name _ v = typeMismatch name "Ext 0x00" v

withArray :: T.Text -> (V.Vector Value -> Converter a) -> Value -> Converter a
{-# INLINE withArray #-}
withArray _ f (Array arr) = f arr
withArray name _ v      = typeMismatch name "Arr" 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 _    f (Map kvs) = f kvs
withKeyValues name _ v            = typeMismatch name "Map" 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 _    f (Map obj) = f (FM.packVector obj)
withFlatMap name _ v            = typeMismatch name "Map" 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 _    f (Map obj) = f (FM.packVectorR obj)
withFlatMapR name _ v            = typeMismatch name "Map" 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 (.:) #-}
(.:) = convertField 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 (.:?) #-}
(.:?) = convertFieldMaybe 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 (.:!) #-}
(.:!) = convertFieldMaybe' 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 p obj key = case FM.lookup (Str key) obj of
    Just v -> p v <?> Key key
    _      -> fail' (T.concat $ ["key ", key, " not present"])

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

-- | Variant of '.:!' with explicit converter function.
convertFieldMaybe' :: (Value -> Converter a) -> FM.FlatMap Value Value -> T.Text -> Converter (Maybe a)
{-# INLINE convertFieldMaybe' #-}
convertFieldMaybe' p obj key = case FM.lookup (Str key) obj of
    Just v -> Just <$> p v <?> Key key
    _      -> pure 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 siza a <> KVItem sizb b = KVItem (siza+sizb) (a >> b)

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

-- | Write map header and 'KVItem's.
object' :: KVItem -> B.Builder ()
{-# INLINE object' #-}
object' (KVItem siz kvb) = MB.mapHeader siz >> kvb

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

-- | Alias for @Map . pack@.
object :: [(Value, Value)] -> Value
{-# INLINE object #-}
object = Map . V.pack

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

-- | @Settings T.pack T.pack False@
defaultSettings :: Settings
defaultSettings = Settings T.pack T.pack False

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

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

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

type family Field f where
    Field (a :*: b) = Field a
    Field (S1 (MetaSel Nothing u ss ds) f) = Value
    Field (S1 (MetaSel (Just l) u ss ds) f) = (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 s marr idx (a :*: b) = do
        gWriteFields s marr idx a
        gWriteFields s marr (idx + productSize (proxy# :: Proxy# a)) b

instance (GToValue f) => GWriteFields (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gWriteFields #-}
    gWriteFields s marr idx (M1 x) = A.writeSmallArray marr idx (gToValue s x)

instance (GToValue f, Selector (MetaSel (Just l) u ss ds)) => GWriteFields (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gWriteFields #-}
    gWriteFields s marr idx m1@(M1 x) = A.writeSmallArray marr idx ((Str $ (fieldFmt s) (selName m1)), gToValue s x)

instance (GToValue f, Selector (MetaSel (Just l) u ss ds)) => GToValue (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gToValue #-}
    gToValue s m1@(M1 x) =
        let k = fieldFmt s $ selName m1
            v = gToValue s x
        in Map (V.singleton (Str k, v))

instance GToValue f => GToValue (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gToValue #-}
    gToValue s (M1 x) = gToValue s x

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

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

instance GMergeFields a => GMergeFields (a :*: b) where
    {-# INLINE gMergeFields #-}
    gMergeFields _ = gMergeFields (proxy# :: Proxy# a)

instance GMergeFields (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gMergeFields #-}
    gMergeFields _ marr = do
        arr <- A.unsafeFreezeSmallArray marr
        let l = A.sizeofSmallArray arr
        pure (Array (V.Vector arr 0 l))

instance GMergeFields (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gMergeFields #-}
    gMergeFields _ marr = do
        arr <- A.unsafeFreezeSmallArray marr
        let l = A.sizeofSmallArray arr
        pure (Map (V.Vector arr 0 l))

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

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

instance GConstrToValue V1 where
    {-# INLINE gConstrToValue #-}
    gConstrToValue _ _ _ = error "Z.Data.MessagePack.Base: empty data type"

instance (GConstrToValue f, GConstrToValue g) => GConstrToValue (f :+: g) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue _ s (L1 x) = gConstrToValue True s x
    gConstrToValue _ s (R1 x) = gConstrToValue True s x

-- | Constructor without payload, convert to String
instance (Constructor c) => GConstrToValue (C1 c U1) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue _ s (M1 _) = Str . constrFmt s $ conName (undefined :: t c U1 a)

-- | Constructor with a single payload
instance (Constructor c, GToValue (S1 sc f)) => GConstrToValue (C1 c (S1 sc f)) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue False s (M1 x) = gToValue s x
    gConstrToValue True s (M1 x) =
        let !k = constrFmt s $ conName @c undefined
            !v = gToValue s x
        in Map (V.singleton (Str k, v))

-- | Constructor with multiple payloads
instance (ProductSize (a :*: b), GWriteFields (a :*: b), GMergeFields (a :*: b), Constructor c)
    => GConstrToValue (C1 c (a :*: b)) where
    {-# INLINE gConstrToValue #-}
    gConstrToValue False s (M1 x) = runST (do
        marr <- A.newSmallArray (productSize (proxy# :: Proxy# (a :*: b))) undefined
        gWriteFields s marr 0 x
        gMergeFields (proxy# :: Proxy# (a :*: b)) marr)
    gConstrToValue True s (M1 x) =
        let !k = constrFmt s $ conName @c undefined
            !v = runST (do
                    marr <- A.newSmallArray (productSize (proxy# :: Proxy# (a :*: b))) undefined
                    gWriteFields s marr 0 x
                    gMergeFields (proxy# :: Proxy# (a :*: b)) marr)
        in Map (V.singleton (Str k, v))

--------------------------------------------------------------------------------
-- Data types
instance GConstrToValue f => GToValue (D1 c f) where
    {-# INLINE gToValue #-}
    gToValue s (M1 x) = gConstrToValue False s 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 s m1@(M1 x) = (MB.str . fieldFmt s $ selName m1) >> gEncodeMessagePack s x

instance GEncodeMessagePack f => GEncodeMessagePack (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gEncodeMessagePack #-}
    gEncodeMessagePack s (M1 x) = gEncodeMessagePack s x

instance (GEncodeMessagePack a, GEncodeMessagePack b) => GEncodeMessagePack (a :*: b) where
    {-# INLINE gEncodeMessagePack #-}
    gEncodeMessagePack s (a :*: b) = gEncodeMessagePack s a >> gEncodeMessagePack s b

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

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

instance GAddProductSize a => GAddProductSize (a :*: b) where
    {-# INLINE gAddProductSize #-}
    gAddProductSize _ = gAddProductSize (proxy# :: Proxy# a)

instance GAddProductSize (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gAddProductSize #-}
    gAddProductSize _ = MB.arrayHeader

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

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

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

instance GConstrEncodeMessagePack V1 where
    {-# INLINE gConstrEncodeMessagePack #-}
    gConstrEncodeMessagePack _ _ _ = error "Z.Data.MessagePack.Base: empty data type"

instance (GConstrEncodeMessagePack f, GConstrEncodeMessagePack g) => GConstrEncodeMessagePack (f :+: g) where
    {-# INLINE gConstrEncodeMessagePack #-}
    gConstrEncodeMessagePack _ s (L1 x) = gConstrEncodeMessagePack True s x
    gConstrEncodeMessagePack _ s (R1 x) = gConstrEncodeMessagePack True s 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 _ s (M1 _) = MB.str . constrFmt s $ conName (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 False s (M1 x) = do
        gEncodeMessagePack s x
    gConstrEncodeMessagePack True s (M1 x) = do
        MB.mapHeader 1
        MB.str (constrFmt s $ conName @c undefined)
        gEncodeMessagePack s 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 False s (M1 x) = do
        MB.mapHeader 1
        gEncodeMessagePack s x
    gConstrEncodeMessagePack True s (M1 x) = do
        MB.mapHeader 1
        MB.str (constrFmt s $ conName @c undefined)
        MB.mapHeader 1
        gEncodeMessagePack s 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 False s (M1 x) = do
        gAddProductSize (proxy# :: Proxy# (a :*: b)) (productSize (proxy# :: Proxy# (a :*: b)))
        gEncodeMessagePack s x
    gConstrEncodeMessagePack True s (M1 x) = do
        MB.mapHeader 1
        MB.str (constrFmt s $ conName @c @_ @_ @_ undefined)
        gAddProductSize (proxy# :: Proxy# (a :*: b)) (productSize (proxy# :: Proxy# (a :*: b)))
        gEncodeMessagePack s x

--------------------------------------------------------------------------------
-- Data types
instance GConstrEncodeMessagePack f => GEncodeMessagePack (D1 c f) where
    {-# INLINE gEncodeMessagePack #-}
    gEncodeMessagePack s (M1 x) = gConstrEncodeMessagePack False s x

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

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

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

type family LookupTable f where
    LookupTable (a :*: b) = LookupTable a
    LookupTable (S1 (MetaSel Nothing u ss ds) f) = V.Vector Value
    LookupTable (S1 (MetaSel (Just l) u ss ds) f) = FM.FlatMap 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 s v idx = do
        a <- gFromFields s v idx
        b <- gFromFields s v (idx + productSize (proxy# :: Proxy# a))
        pure (a :*: b)

instance (GFromValue f) => GFromFields (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gFromFields #-}
    gFromFields s v idx = do
        v' <- V.unsafeIndexM v idx
        M1 <$> gFromValue s v' <?> Index idx

instance (GFromValue f, Selector (MetaSel (Just l) u ss ds)) => GFromFields (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gFromFields #-}
    gFromFields s v _ = do
        case FM.lookup (Str fn) v of
            Just v' -> M1 <$> gFromValue s v' <?> Key fn
            _ | missingKeyAsNil s -> M1 <$> gFromValue s Nil <?> Key fn
              | otherwise -> fail' ("Z.Data.MessagePack.Base: missing field " <>  fn)
      where
        fn = (fieldFmt s) (selName (undefined :: S1 (MetaSel (Just l) u ss ds) f a))

instance GFromValue f => GFromValue (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gFromValue #-}
    gFromValue s x = M1 <$> gFromValue s x

instance (GFromValue f, Selector (MetaSel (Just l) u ss ds)) => GFromValue (S1 (MetaSel (Just l) u ss ds) f) where
    {-# INLINE gFromValue #-}
    gFromValue s (Map v) = do
        case FM.lookup (Str fn) (FM.packVectorR v) of
            Just v' -> M1 <$> gFromValue s v' <?> Key fn
            _ | missingKeyAsNil s -> M1 <$> gFromValue s Nil <?> Key fn
              | otherwise -> fail' ("Z.Data.MessagePack.Base: missing field " <>  fn)
      where fn = (fieldFmt s) (selName (undefined :: S1 (MetaSel (Just l) u ss ds) f a))
    gFromValue s v = typeMismatch ("field " <> fn) "Map" v <?> Key fn
      where fn = (fieldFmt s) (selName (undefined :: S1 (MetaSel (Just l) u ss ds) f a))

instance MessagePack a => GFromValue (K1 i a) where
    {-# INLINE gFromValue #-}
    gFromValue _ x = K1 <$> fromValue x

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

instance (GBuildLookup a, GBuildLookup b) => GBuildLookup (a :*: b) where
    {-# INLINE gBuildLookup #-}
    gBuildLookup _ siz = gBuildLookup (proxy# :: Proxy# a) siz

instance GBuildLookup (S1 (MetaSel Nothing u ss ds) f) where
    {-# INLINE gBuildLookup #-}
    gBuildLookup _ siz name (Array v)
        -- we have to check size here to use 'unsafeIndexM' later
        | siz' /= siz = fail' . B.unsafeBuildText $ do
            "converting "
            T.text name
            " failed, product size mismatch, expected "
            T.int siz
            ", get"
            T.int siz'
        | otherwise = pure v
      where siz' = V.length v
    gBuildLookup _ _   name x         = typeMismatch name "Array" x

instance GBuildLookup (S1 ((MetaSel (Just l) u ss ds)) f) where
    {-# INLINE gBuildLookup #-}
    -- we don't check size, so that duplicated keys are preserved
    gBuildLookup _ _ _ (Map v) = pure $! FM.packVectorR v
    gBuildLookup _ _ name x    = typeMismatch name "Map" x

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

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

instance GConstrFromValue V1 where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue _ _ _ = error "Z.Data.MessagePack.Base: empty data type"

instance (GConstrFromValue f, GConstrFromValue g) => GConstrFromValue (f :+: g) where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue _ s x = (L1 <$> gConstrFromValue True s x) <|> (R1 <$> gConstrFromValue True s x)

-- | Constructor without payload, convert to String
instance (Constructor c) => GConstrFromValue (C1 c U1) where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue _ s (Str x)
        | cn == x   = pure (M1 U1)
        | otherwise = fail' . T.concat $ ["converting ", cn', "failed, unknown constructor name ", x]
      where cn = constrFmt s $ conName (undefined :: t c U1 a)
            cn' = T.pack $ conName (undefined :: t c U1 a)
    gConstrFromValue _ _ v = typeMismatch cn' "String" v
      where cn' = T.pack $ conName (undefined :: t c U1 a)

-- | Constructor with a single payload
instance (Constructor c, GFromValue (S1 sc f)) => GConstrFromValue (C1 c (S1 sc f)) where
    {-# INLINE gConstrFromValue #-}
    -- | Single constructor
    gConstrFromValue False s x = M1 <$> gFromValue s x
    gConstrFromValue True s x = case x of
        Map v -> case V.indexM v 0 of
            Just (Str k, v')
                | k == cn -> M1 <$> gFromValue s v' <?> Key cn
            _             -> fail' .T.concat $ ["converting ", cn', " failed, constructor not found"]
        _ ->  typeMismatch cn' "Map" x
      where cn = constrFmt s $ conName @c undefined
            cn' = T.pack $ conName @c undefined

-- | Constructor with multiple payloads
instance (ProductSize (a :*: b), GFromFields (a :*: b), GBuildLookup (a :*: b), Constructor c)
    => GConstrFromValue (C1 c (a :*: b)) where
    {-# INLINE gConstrFromValue #-}
    gConstrFromValue False s x = do
        t <- gBuildLookup p (productSize p) cn' x
        M1 <$> gFromFields s t 0
      where cn' = T.pack $ conName @c undefined
            p = proxy# :: Proxy# (a :*: b)
    gConstrFromValue True s x = case x of
        Map v -> case V.indexM v 0 of
            Just (Str k, v')
                | k == cn -> do t <- gBuildLookup p (productSize p) cn' v'
                                M1 <$> gFromFields s t 0
            _             -> fail' .T.concat $ ["converting ", cn', " failed, constructor not found"]
        _ ->  typeMismatch cn' "Map" x
      where cn = constrFmt s $ conName @c undefined
            cn' = T.pack $ conName @c undefined
            p = proxy# :: Proxy# (a :*: b)

--------------------------------------------------------------------------------
-- Data types
instance GConstrFromValue f => GFromValue (D1 c f) where
    {-# INLINE gFromValue #-}
    gFromValue s x = M1 <$> gConstrFromValue False s x

--------------------------------------------------------------------------------
-- Built-in Instances
--------------------------------------------------------------------------------
-- | Use 'Nil' as @Proxy a@
instance MessagePack (Proxy a) where
    {-# INLINE fromValue #-}; fromValue = fromNil "Proxy" Proxy;
    {-# INLINE toValue #-}; toValue _ = Nil;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack _ = MB.nil;

instance MessagePack Value   where
    {-# INLINE fromValue #-}; fromValue = pure;
    {-# INLINE toValue #-}; toValue = id;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack = MB.value;

instance MessagePack T.Text   where
    {-# INLINE fromValue #-}; fromValue = withStr "Text" pure;
    {-# INLINE toValue #-}; toValue = Str;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack = MB.str;

-- | Note this instance doesn't reject large input
instance MessagePack Scientific where
    {-# INLINE fromValue #-}
    fromValue = withScientific "Data.Scientific.Scientific" pure
    {-# INLINE toValue #-}
    toValue x = MB.scientificValue (coefficient x) (fromIntegral $ base10Exponent x)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack x = MB.scientific (coefficient x) (fromIntegral $ base10Exponent x)

-- | default instance prefer later key
instance (Ord a, MessagePack a, MessagePack b) => MessagePack (FM.FlatMap a b) where
    {-# INLINE fromValue #-}
    fromValue = withFlatMapR "Z.Data.Vector.FlatMap.FlatMap" $ \ m ->
        let kvs = V.unpack (FM.sortedKeyValues m)
        in FM.packR <$> (forM kvs $ \ (k, v) -> do
            k' <- fromValue k
            v' <- fromValue v <?> Key (T.toText k)
            return (k', v'))
    {-# INLINE toValue #-}
    toValue = Map . V.map (\ (k, v) -> (toValue k, toValue v)) . FM.sortedKeyValues
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.map encodeMessagePack encodeMessagePack . FM.sortedKeyValues

instance (Ord a, MessagePack a) => MessagePack (FS.FlatSet a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Vector.FlatSet.FlatSet" $ \ vs ->
        FS.packRN (V.length vs) <$>
            (zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs))
    {-# INLINE toValue #-}
    toValue = Array . V.map' toValue . FS.sortedValues
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array encodeMessagePack . 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 = withKeyValues "Data.HashMap.HashMap" $ \ kvs ->
        HM.fromList <$> (forM (V.unpack kvs) $ \ (k, v) -> do
            !k' <- fromValue k
            !v' <- fromValue v <?> Key (T.toText k)
            return (k', v'))
    {-# INLINE toValue #-}
    toValue = Map . V.pack . map (\ (k,v) -> (toValue k, toValue v)) . HM.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.map' encodeMessagePack encodeMessagePack . HM.toList

instance (Ord a, MessagePack a, MessagePack b) => MessagePack (M.Map a b) where
    {-# INLINE fromValue #-}
    fromValue = withKeyValues "Data.HashMap.HashMap" $ \ kvs ->
        M.fromList <$> (forM (V.unpack kvs) $ \ (k, v) -> do
            !k' <- fromValue k
            !v' <- fromValue v <?> Key (T.toText k)
            return (k', v'))
    {-# INLINE toValue #-}
    toValue = Map . V.pack . map (\ (k,v) -> (toValue k, toValue v)) . M.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.map' encodeMessagePack encodeMessagePack . M.toList

instance MessagePack a => MessagePack (FIM.FlatIntMap a) where
    {-# INLINE fromValue #-}
    fromValue = withFlatMapR "Z.Data.Vector.FlatIntMap.FlatIntMap" $ \ m ->
        let kvs = FM.sortedKeyValues m
        in FIM.packVectorR <$> (forM kvs $ \ (k, v) -> do
            case k of
                Int k' -> do
                    v' <- fromValue v <?> Key (T.toText k)
                    return (V.IPair (fromIntegral k') v')
                _ -> fail' ("converting Z.Data.Vector.FlatIntMap.FlatIntMap failed, unexpected key " <> (T.toText k)))
    {-# INLINE toValue #-}
    toValue = Map . V.map' toKV . FIM.sortedKeyValues
      where toKV (V.IPair i x) = let !k = Int (fromIntegral i)
                                     !v = toValue x
                                 in (k, v)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack m = do
        let kvs = FIM.sortedKeyValues m
        MB.mapHeader (V.length kvs)
        V.traverseVec_ (\ (V.IPair k v) -> MB.int (fromIntegral k) >> encodeMessagePack v) kvs

instance MessagePack a => MessagePack (IM.IntMap a) where
    {-# INLINE fromValue #-}
    fromValue = withKeyValues "Data.IntMap.IntMap" $ \ kvs ->
        IM.fromList <$> (forM (V.unpack kvs) $ \ (k, v) -> do
            case k of
                Int k' -> do
                    v' <- fromValue v <?> Key (T.toText k)
                    return (fromIntegral k', v')
                _ -> fail' ("converting Data.IntMap.IntMap failed, unexpected key " <> (T.toText k)))
    {-# INLINE toValue #-}
    toValue = Map . V.pack . map toKV . IM.toList
      where toKV (i, x) = let !k = Int (fromIntegral i)
                              !v = toValue x
                          in (k, v)
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack m = do
        MB.mapHeader (IM.size m)
        mapM_ (\ (k, v) -> MB.int (fromIntegral k) >> encodeMessagePack v) (IM.toList m)

instance MessagePack FIS.FlatIntSet where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Vector.FlatIntSet.FlatIntSet" $ \ vs ->
        FIS.packRN (V.length vs) <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
    {-# INLINE toValue #-}
    toValue = toValue . FIS.sortedValues
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = encodeMessagePack . FIS.sortedValues

instance MessagePack IS.IntSet where
    {-# INLINE fromValue #-}
    fromValue = withArray "Data.IntSet.IntSet" $ \ vs ->
        IS.fromList <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
    {-# INLINE toValue #-}
    toValue = toValue . IS.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = encodeMessagePack . IS.toList

instance (Ord a, MessagePack a) => MessagePack (Set.Set a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Data.Set.Set" $ \ vs ->
        Set.fromList <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
    {-# INLINE toValue #-}
    toValue = toValue . Set.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = encodeMessagePack . Set.toList

instance MessagePack a => MessagePack (Seq.Seq a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Data.Seq.Seq" $ \ vs ->
        Seq.fromList <$> zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
    {-# INLINE toValue #-}
    toValue = toValue . Foldable.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = encodeMessagePack . Foldable.toList

instance MessagePack a => MessagePack (Tree.Tree a) where
    {-# INLINE fromValue #-}
    fromValue = withFlatMapR "Data.Tree" $ \obj -> do
        !n <- obj .: "rootLabel"
        !d <- obj .: "subForest"
        pure (Tree.Node n d)
    {-# INLINE toValue #-}
    toValue x = object [ "rootLabel" .= (Tree.rootLabel x) , "subForest" .= (Tree.subForest x) ]
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack x = object' ( "rootLabel" .! (Tree.rootLabel x) <> "subForest" .! (Tree.subForest x) )

instance MessagePack a => MessagePack (A.Array a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Array.Array"
        (V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
    {-# INLINE toValue #-}
    toValue = Array . V.map toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array encodeMessagePack

instance MessagePack a => MessagePack (A.SmallArray a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Array.SmallArray"
        (V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
    {-# INLINE toValue #-}
    toValue = Array . V.map toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array encodeMessagePack

instance (Prim a, MessagePack a) => MessagePack (A.PrimArray a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Array.PrimArray"
        (V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
    {-# INLINE toValue #-}
    toValue = Array . V.map toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array encodeMessagePack

instance (A.PrimUnlifted a, MessagePack a) => MessagePack (A.UnliftedArray a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Array.UnliftedArray"
        (V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
    {-# INLINE toValue #-}
    toValue = Array . V.map toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array encodeMessagePack

instance MessagePack A.ByteArray where
    {-# INLINE fromValue #-}
    fromValue = withBin "ByteArray" $ \ (V.PrimVector pa@(A.PrimArray ba#) s l) ->
        if A.sizeofArr pa == l && s == 0
        then pure (A.ByteArray ba#)
        else pure $! A.cloneByteArray (A.ByteArray ba#) s l
    {-# INLINE toValue #-}
    toValue (A.ByteArray ba#) = Bin (V.arrVec (A.PrimArray ba#))
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack (A.ByteArray ba#) = MB.bin (V.arrVec (A.PrimArray ba#))

instance (Prim a, MessagePack a) => MessagePack (V.PrimVector a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Vector.PrimVector"
        (V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
    {-# INLINE toValue #-}
    toValue = Array . V.map toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array encodeMessagePack

-- | This is an INCOHERENT instance, write 'Bytes' as Bin.
instance {-# INCOHERENT #-} MessagePack V.Bytes where
    {-# INLINE fromValue #-}
    fromValue = withBin "Z.Data.Vector.Bytes" pure
    {-# INLINE toValue #-}
    toValue = Bin
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.bin

-- | Write 'CBytes' as Bin not Str.
instance MessagePack CBytes.CBytes where
    {-# INLINE fromValue #-}
    fromValue = withBin "Z.Data.CBytes" (pure . CBytes.fromBytes)
    {-# INLINE toValue #-}
    toValue = Bin . CBytes.toBytes
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.bin . CBytes.toBytes

instance MessagePack a => MessagePack (V.Vector a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Vector.Vector"
        (V.traverseWithIndex $ \ k v -> fromValue v <?> Index k)
    {-# INLINE toValue #-}
    toValue = Array . V.map toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array encodeMessagePack

instance (Eq a, Hashable a, MessagePack a) => MessagePack (HS.HashSet a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "Z.Data.Vector.FlatSet.FlatSet" $ \ vs ->
        HS.fromList <$>
            (zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs))
    {-# INLINE toValue #-}
    toValue = toValue . HS.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = encodeMessagePack . HS.toList

instance MessagePack a => MessagePack [a] where
    {-# INLINE fromValue #-}
    fromValue = withArray "[a]" $ \ vs ->
        zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
    {-# INLINE toValue #-}
    toValue = Array . V.pack . map toValue
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.array' encodeMessagePack

-- | This is an INCOHERENT instance, encode 'String' with 'Str'.
instance {-# INCOHERENT #-} MessagePack String where
    {-# INLINE fromValue #-}
    fromValue = withStr "String" (pure . T.unpack)
    {-# INLINE toValue #-}
    toValue = Str . T.pack
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.str . T.pack

instance MessagePack a => MessagePack (NonEmpty a) where
    {-# INLINE fromValue #-}
    fromValue = withArray "NonEmpty" $ \ vs -> do
        l <- zipWithM (\ k v -> fromValue v <?> Index k) [0..] (V.unpack vs)
        case l of (x:xs) -> pure (x :| xs)
                  _      -> fail' "unexpected empty array"
    {-# INLINE toValue #-}
    toValue = toValue . NonEmpty.toList
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = encodeMessagePack . NonEmpty.toList

instance MessagePack Bool where
    {-# INLINE fromValue #-}; fromValue = withBool "Bool" pure;
    {-# INLINE toValue #-}; toValue = Bool;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack = MB.bool

instance MessagePack Char where
    {-# INLINE fromValue #-}
    fromValue = withStr "Char" $ \ t ->
        if (T.length t == 1)
        then pure (T.head t)
        else fail' (T.concat ["converting Char failed, expected a string of length 1"])
    {-# INLINE toValue #-}
    toValue = Str . T.singleton
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack = MB.str . T.singleton

instance MessagePack Double where
    {-# INLINE fromValue #-}
    fromValue (Float d) = pure $! realToFrac d
    fromValue (Double d) = pure d
    fromValue v = typeMismatch "Double" "Float or Double" v
    {-# INLINE toValue #-}; toValue = Double;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack = MB.double;

instance MessagePack Float  where
    {-# INLINE fromValue #-};
    fromValue (Float d) = pure d
    fromValue (Double d) = pure $! realToFrac d
    fromValue v = typeMismatch "Float" "Float or Double" v
    {-# INLINE toValue #-}; toValue = Float;
    {-# INLINE encodeMessagePack #-}; encodeMessagePack = 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 = withBoundedScientific "Integer" $ \ n ->
        case Sci.floatingOrInteger n :: Either Double Integer of
            Right x -> pure x
            Left _  -> fail' . B.unsafeBuildText $ do
                "converting Integer failed, unexpected floating number "
                T.scientific n
    {-# INLINE toValue #-}
    toValue x = MB.scientificValue x 0
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack x = MB.scientific x 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 = withBoundedScientific "Natural" $ \ n ->
        if n < 0
        then fail' . B.unsafeBuildText $ do
                "converting Natural failed, unexpected negative number "
                T.scientific n
        else case Sci.floatingOrInteger n :: Either Double Natural of
            Right x -> pure x
            Left _  -> fail' . B.unsafeBuildText $ do
                "converting Natural failed, unexpected floating number "
                T.scientific n
    {-# INLINE toValue #-}
    toValue x = MB.scientificValue (fromIntegral x) 0
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack x = MB.scientific (fromIntegral x) 0

instance MessagePack Ordering where
    {-# INLINE fromValue #-}
    fromValue = withStr "Ordering" $ \ s ->
        case s of
            "LT" -> pure LT
            "EQ" -> pure EQ
            "GT" -> pure GT
            _ -> fail' . T.concat $ ["converting Ordering failed, unexpected ",
                                        s, " expected \"LT\", \"EQ\", or \"GT\""]
    {-# INLINE toValue #-}
    toValue LT = Str "LT"
    toValue EQ = Str "EQ"
    toValue GT = Str "GT"
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack LT = MB.str "LT"
    encodeMessagePack EQ = MB.str "EQ"
    encodeMessagePack GT = MB.str "GT"

instance MessagePack () where
    {-# INLINE fromValue #-}
    fromValue = withArray "()" $ \ v ->
        if V.null v
        then pure ()
        else fail' "converting () failed, expected an empty array"
    {-# INLINE toValue #-}
    toValue () = Array V.empty
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack () = MB.arrayHeader 0

instance MessagePack a => MessagePack (Maybe a) where
    {-# INLINE fromValue #-}
    fromValue Nil = pure Nothing
    fromValue v    = Just <$> fromValue v
    {-# INLINE toValue #-}
    toValue Nothing  = Nil
    toValue (Just x) = toValue x
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack Nothing  = MB.nil
    encodeMessagePack (Just x) = encodeMessagePack x

instance (MessagePack a, Integral a) => MessagePack (Ratio a) where
    {-# INLINE fromValue #-}
    fromValue = withFlatMapR "Rational" $ \obj -> do
        !n <- obj .: "numerator"
        !d <- obj .: "denominator"
        if d == 0
        then fail' "Ratio denominator was 0"
        else pure (n % d)
    {-# INLINE toValue #-}
    toValue x = object [ "numerator" .= (numerator x) , "denominator" .= (denominator x) ]
    {-# INLINE encodeMessagePack #-}
    encodeMessagePack x = object' ( "numerator" .! (numerator x) <> "denominator" .! (denominator x) )

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