summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorwinterland <>2021-01-12 13:49:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2021-01-12 13:49:00 (GMT)
commit890059b1155f4476bd35f58cb54cc848d5076cd9 (patch)
tree6e8e8bc99126b4d99f3a85ecdf1440b9b48b4727
version 0.1.0.00.1.0.0
Diffstat
-rwxr-xr-xCHANGELOG.md5
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--Z-MessagePack.cabal105
-rw-r--r--Z/Data/MessagePack.hs97
-rw-r--r--Z/Data/MessagePack/Base.hs1410
-rw-r--r--Z/Data/MessagePack/Builder.hs211
-rw-r--r--Z/Data/MessagePack/Value.hs166
-rw-r--r--test/Spec.hs2
-rw-r--r--test/Z/Data/MessagePack/BaseSpec.hs307
10 files changed, 2335 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100755
index 0000000..b7ee0c9
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for Z-Redis
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..79a5f30
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2017-2020, Dong Han
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of winter nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Z-MessagePack.cabal b/Z-MessagePack.cabal
new file mode 100644
index 0000000..4fca67e
--- /dev/null
+++ b/Z-MessagePack.cabal
@@ -0,0 +1,105 @@
+cabal-version: >=1.10
+name: Z-MessagePack
+version: 0.1.0.0
+synopsis: MessagePack
+description: MessagePack binary serialization format.
+license: BSD3
+license-file: LICENSE
+author: Dong Han
+maintainer: winterland1989@gmail.com
+copyright: (c) Hideyuki Tanaka, 2009-2015, (c) Dong Han, 2020
+category: Data
+build-type: Simple
+homepage: https://github.com/haskell-Z/z-redis
+bug-reports: https://github.com/haskell-Z/z-redis/issues
+
+extra-source-files: CHANGELOG.md
+
+library
+ exposed-modules: Z.Data.MessagePack
+ Z.Data.MessagePack.Base
+ Z.Data.MessagePack.Builder
+ Z.Data.MessagePack.Value
+
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base >=4.14 && <4.15
+ , deepseq >= 1.4 && < 1.5
+ , primitive >= 0.7.1 && < 0.7.2
+ , QuickCheck >= 2.10
+ , scientific == 0.3.*
+ , hashable == 1.3.*
+ , unordered-containers == 0.2.*
+ , containers == 0.6.*
+ , integer-gmp == 1.*
+ , tagged == 0.8.*
+ , time >= 1.9 && < 2.0
+ , Z-Data == 0.4.*
+ , Z-IO == 0.4.*
+
+ -- hs-source-dirs:
+ default-language: Haskell2010
+ default-extensions: BangPatterns
+ BinaryLiterals
+ CApiFFI
+ ConstraintKinds
+ CPP
+ DerivingStrategies
+ DeriveGeneric
+ DeriveAnyClass
+ DefaultSignatures
+ DataKinds
+ ExistentialQuantification
+ FlexibleContexts
+ FlexibleInstances
+ GeneralizedNewtypeDeriving
+ KindSignatures
+ MagicHash
+ MultiParamTypeClasses
+ MultiWayIf
+ PartialTypeSignatures
+ PatternSynonyms
+ PolyKinds
+ QuantifiedConstraints
+ QuasiQuotes
+ OverloadedStrings
+ RankNTypes
+ RecordWildCards
+ ScopedTypeVariables
+ StandaloneDeriving
+ TemplateHaskell
+ TypeApplications
+ TypeFamilyDependencies
+ TypeFamilies
+ TypeOperators
+ TupleSections
+ UnboxedTuples
+ UnliftedFFITypes
+ ViewPatterns
+
+
+test-suite Z-MessagePack-Test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test/
+ build-depends: base
+ , Z-IO
+ , Z-Data
+ , Z-MessagePack
+ , hspec >= 2.5.4
+ , hashable
+ , unordered-containers
+ , containers
+ , HUnit
+ , QuickCheck >= 2.10
+ , quickcheck-instances
+ , scientific
+ , primitive
+ , time
+
+ other-modules: Z.Data.MessagePack.BaseSpec
+
+ ghc-options: -threaded
+ default-language: Haskell2010
+ build-tool-depends: hspec-discover:hspec-discover == 2.*
+
diff --git a/Z/Data/MessagePack.hs b/Z/Data/MessagePack.hs
new file mode 100644
index 0000000..dc5a039
--- /dev/null
+++ b/Z/Data/MessagePack.hs
@@ -0,0 +1,97 @@
+{-|
+Module : Z.Data.MessagePack
+Description : Fast MessagePack serialization/deserialization
+Copyright : (c) Dong Han, 2019
+License : BSD
+Maintainer : winterland1989@gmail.com
+Stability : experimental
+Portability : non-portable
+
+This module provides an interface similar to 'Z.Data.JSON', to work with MessagePack binary format.
+
+ * @Maybe a@ convert to 'Nil' in 'Nothing' case, and @a@ in 'Just' case.
+ * Use 'Int64'(signed) or 'Word64'(unsigned) type to marshall int type format, smaller types will sliently truncate when overflow.
+ * Use 'Double' to marshall float type format, 'Float' may lost precision.
+ * Use 'Scientific' to marshall 'Ext' @0x00\/0x01@ type.
+ * Use 'SystemTime' to marshall 'Ext' @0xFF@ type.
+ * Record's field label are preserved.
+
+ * We use MessagePack extension type -1 to encode\/decode 'SystemTime' and 'UTCTime':
+
+ +--------+--------+--------+-----------------------------------+------------------------------+
+ | 0xc7 | 12 | -1 |nanoseconds in 32-bit unsigned int | seconds in 64-bit signed int |
+ +--------+--------+--------+-----------------------------------+------------------------------+
+
+ * We deliberately use ext type 0x00(positive) and 0x01(negative) to represent large numbers('Integer', 'Scientific', 'Fixed', 'DiffTime'...):
+
+ +--------+--------+--------+-----------------------------------------+---------------------------------------+
+ | 0xc7 |XXXXXXXX| 0x00 | base10 exponent(MessagePack int format) | coefficient(big endian 256-base limbs |
+ +--------+--------+--------+-----------------------------------------+---------------------------------------+
+
+ Use a MessagePack implementation supporting ext type to marshall it, result value is coefficient * (10 ^ exponent).
+
+The easiest way to use the library is to define target data type, deriving 'GHC.Generics.Generic' and 'MessagePack' instances, e.g.
+
+@
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies #-}
+
+import GHC.Generics (Generic)
+import qualified Z.Data.MessagePack as MessagePack
+import qualified Z.Data.Text as T
+
+data Person = Person {name :: T.Text, age :: Int}
+ deriving (Show, Generic)
+ deriving anyclass (MessagePack.MessagePack)
+
+> MessagePack.encode Person{ name="Alice", age=16 }
+> [130,164,110,97,109,101,165,65,108,105,99,101,163,97,103,101,16]
+@
+
+MessagePack is a schemaless format, which means the encoded data can be recovered into some form('Value' in haskell case)
+without providing data definition, e.g. the data encoded above:
+
+> [130, 164, 110, 97, 109, 101, 165, 65, 108, 105, 99, 101, 163, 97, 103, 101, 16]
+> 0x82 0xA4 'n' 'a' 'm' 'e' 0xA5 'A' 'l' 'i' 'c' 'e' 0xA3 'a' 'g' 'e' int
+> map str str str 16
+> 2kvs 4bytes 5bytes 3bytes
+
+
+This property makes it suitable for passing data across language boundary, e.g. from a static typed language to a dynamic one,
+at the cost of a lower space efficiency(i.e. type tag and field label).
+
+-}
+
+module Z.Data.MessagePack
+ ( -- * MessagePack Class
+ MessagePack(..), Value(..), defaultSettings, Settings(..), JSON.snakeCase, JSON.trainCase
+ -- * Encode & Decode
+ , readMessagePackFile, writeMessagePackFile
+ , decode, decode', decodeChunks, decodeChunks', encode, encodeChunks
+ , DecodeError, ParseError
+ -- * parse into MessagePack Value
+ , parseValue, parseValue', parseValueChunks, parseValueChunks'
+ -- * Generic FromValue, ToValue & EncodeMessagePack
+ , gToValue, gFromValue, gEncodeMessagePack
+ -- * Convert 'Value' to Haskell data
+ , convertValue, Converter(..), fail', (<?>), prependContext
+ , PathElement(..), ConvertError(..)
+ , typeMismatch, fromNil, withBool
+ , withStr, withBin, withArray, withKeyValues, withFlatMap, withFlatMapR
+ , (.:), (.:?), (.:!), convertField, convertFieldMaybe, convertFieldMaybe'
+ -- * Helper for manually writing instance.
+ , (.=), object, (.!), object', KVItem
+ ) where
+
+import Z.Data.MessagePack.Base
+import qualified Z.Data.JSON as JSON
+import Z.Data.CBytes (CBytes)
+import Z.IO
+import qualified Z.IO.FileSystem as FS
+
+-- | Decode a 'MessagePack' instance from file.
+readMessagePackFile :: (HasCallStack, MessagePack a) => CBytes -> IO a
+readMessagePackFile p = unwrap . decode' =<< FS.readFile p
+
+-- | Encode a 'MessagePack' instance to file.
+writeMessagePackFile :: (HasCallStack, MessagePack a) => CBytes -> a -> IO ()
+writeMessagePackFile p x = FS.writeFile p (encode x)
diff --git a/Z/Data/MessagePack/Base.hs b/Z/Data/MessagePack/Base.hs
new file mode 100644
index 0000000..cfd8e23
--- /dev/null
+++ b/Z/Data/MessagePack/Base.hs
@@ -0,0 +1,1410 @@
+{-|
+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 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)
+
+-- | 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' mb bs = do
+ mr <- P.parseChunks (MV.value <* P.endOfInput) mb bs
+ case mr of
+ (_, Left pErr) -> pure (Left (Left pErr))
+ (_, Right v) ->
+ case convertValue v of
+ Left cErr -> pure (Left (Right cErr))
+ Right r -> pure (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
+
+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
+
+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 ExitCode where
+ {-# INLINE fromValue #-}
+ fromValue (Str "ExitSuccess") = return ExitSuccess
+ fromValue (Int x) = return (ExitFailure (fromIntegral x))
+ fromValue _ = fail' "converting ExitCode failed, expected a string or number"
+
+ {-# INLINE toValue #-}
+ toValue ExitSuccess = Str "ExitSuccess"
+ toValue (ExitFailure n) = Int (fromIntegral n)
+
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack ExitSuccess = MB.str "ExitSuccess"
+ encodeMessagePack (ExitFailure n) = B.int n
+
+instance MessagePack Version where
+ {-# INLINE fromValue #-}
+ fromValue = withStr "Version" (go . readP_to_S parseVersion . T.unpack)
+ where
+ go [(v,[])] = pure v
+ go (_ : xs) = go xs
+ go _ = fail "converting Version failed"
+ {-# INLINE toValue #-}
+ toValue = Str . T.pack . show
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack = MB.str' . show
+
+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
+
+--------------------------------------------------------------------------------
+
+-- | MessagePack extension type @Ext 0xFF@
+instance MessagePack UTCTime where
+ {-# INLINE fromValue #-}
+ fromValue = withSystemTime "UTCTime" $ pure . systemToUTCTime
+ {-# INLINE toValue #-}
+ toValue t = let (MkSystemTime s ns) = utcToSystemTime t in MB.timestampValue s (fromIntegral ns)
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack t = let (MkSystemTime s ns) = utcToSystemTime t in MB.timestamp s (fromIntegral ns)
+
+-- | MessagePack extension type @Ext 0xFF@
+instance MessagePack SystemTime where
+ {-# INLINE fromValue #-}
+ fromValue = withSystemTime "UTCTime" $ pure
+ {-# INLINE toValue #-}
+ toValue (MkSystemTime s ns) = MB.timestampValue s (fromIntegral ns)
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack (MkSystemTime s ns) = MB.timestamp s (fromIntegral ns)
+
+-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
+instance MessagePack ZonedTime where
+ {-# INLINE fromValue #-}
+ fromValue = withStr "ZonedTime" $ \ t ->
+ case P.parse' (P.zonedTime <* P.endOfInput) (T.getUTF8Bytes t) of
+ Left err -> fail' $ "could not parse date as ZonedTime: " <> T.toText err
+ Right r -> return r
+ {-# INLINE toValue #-}
+ toValue t = Str (B.unsafeBuildText (B.zonedTime t))
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack t = MB.str (B.unsafeBuildText (B.zonedTime t))
+
+-- | @YYYY-MM-DD@
+instance MessagePack Day where
+ {-# INLINE fromValue #-}
+ fromValue = withStr "Day" $ \ t ->
+ case P.parse' (P.day <* P.endOfInput) (T.getUTF8Bytes t) of
+ Left err -> fail' $ "could not parse date as Day: " <> T.toText err
+ Right r -> return r
+ {-# INLINE toValue #-}
+ toValue t = Str (B.unsafeBuildText (B.day t))
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack t = MB.str (B.unsafeBuildText (B.day t))
+
+-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@
+instance MessagePack LocalTime where
+ {-# INLINE fromValue #-}
+ fromValue = withStr "LocalTime" $ \ t ->
+ case P.parse' (P.localTime <* P.endOfInput) (T.getUTF8Bytes t) of
+ Left err -> fail' $ "could not parse date as LocalTime: " <> T.toText err
+ Right r -> return r
+ {-# INLINE toValue #-}
+ toValue t = Str (B.unsafeBuildText (B.localTime t))
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack t = MB.str (B.unsafeBuildText (B.localTime t))
+
+-- | @HH:MM:SS.SSS@
+instance MessagePack TimeOfDay where
+ {-# INLINE fromValue #-}
+ fromValue = withStr "TimeOfDay" $ \ t ->
+ case P.parse' (P.timeOfDay <* P.endOfInput) (T.getUTF8Bytes t) of
+ Left err -> fail' $ "could not parse time as TimeOfDay: " <> T.toText err
+ Right r -> return r
+ {-# INLINE toValue #-}
+ toValue t = Str (B.unsafeBuildText (B.timeOfDay t))
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack t = MB.str (B.unsafeBuildText (B.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 = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
+ {-# INLINE toValue #-}
+ toValue = toValue @Scientific . realToFrac
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack = encodeMessagePack @Scientific . realToFrac
+
+-- | This instance includes a bounds check to prevent maliciously
+-- large inputs to fill up the memory of the target system. You can
+-- newtype 'DiffTime' and provide your own instance using
+-- 'withScientific' if you want to allow larger inputs.
+instance MessagePack DiffTime where
+ {-# INLINE fromValue #-}
+ fromValue = withBoundedScientific "DiffTime" $ pure . realToFrac
+ {-# INLINE toValue #-}
+ toValue = toValue @Scientific . realToFrac
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack = encodeMessagePack @Scientific . realToFrac
+
+instance MessagePack CalendarDiffTime where
+ {-# INLINE fromValue #-}
+ fromValue = withFlatMapR "CalendarDiffTime" $ \ v ->
+ CalendarDiffTime <$> v .: "months" <*> v .: "time"
+ {-# INLINE toValue #-}
+ toValue (CalendarDiffTime m nt) = object [ "months" .= m , "time" .= nt ]
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack (CalendarDiffTime m nt) = object' ("months" .! m <> "time" .! nt)
+
+instance MessagePack CalendarDiffDays where
+ {-# INLINE fromValue #-}
+ fromValue = withFlatMapR "CalendarDiffDays" $ \ v ->
+ CalendarDiffDays <$> v .: "months" <*> v .: "days"
+ {-# INLINE toValue #-}
+ toValue (CalendarDiffDays m d) = object ["months" .= m, "days" .= d]
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack (CalendarDiffDays m d) = object' ("months" .! m <> "days" .! d)
+
+instance MessagePack DayOfWeek where
+ {-# INLINE fromValue #-}
+ fromValue (Str "monday" ) = pure Monday
+ fromValue (Str "tuesday" ) = pure Tuesday
+ fromValue (Str "wednesday") = pure Wednesday
+ fromValue (Str "thursday" ) = pure Thursday
+ fromValue (Str "friday" ) = pure Friday
+ fromValue (Str "saturday" ) = pure Saturday
+ fromValue (Str "sunday" ) = pure Sunday
+ fromValue (Str _ ) = fail' "converting DayOfWeek failed, value should be one of weekdays"
+ fromValue v = typeMismatch "DayOfWeek" "String" v
+ {-# INLINE toValue #-}
+ toValue Monday = Str "monday"
+ toValue Tuesday = Str "tuesday"
+ toValue Wednesday = Str "wednesday"
+ toValue Thursday = Str "thursday"
+ toValue Friday = Str "friday"
+ toValue Saturday = Str "saturday"
+ toValue Sunday = Str "sunday"
+ {-# INLINE encodeMessagePack #-}
+ encodeMessagePack Monday = MB.str "monday"
+ encodeMessagePack Tuesday = MB.str "tuesday"
+ encodeMessagePack Wednesday = MB.str "wednesday"
+ encodeMessagePack Thursday = MB.str "thursday"
+ encodeMessagePack Friday = MB.str "friday"
+ encodeMessagePack Saturday = MB.str "saturday"
+ encodeMessagePack Sunday = MB.str "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)
diff --git a/Z/Data/MessagePack/Builder.hs b/Z/Data/MessagePack/Builder.hs
new file mode 100644
index 0000000..287cf9d
--- /dev/null
+++ b/Z/Data/MessagePack/Builder.hs
@@ -0,0 +1,211 @@
+{-|
+Module : Z.Data.MessagePack.Builder
+Description : MessagePack builders
+Copyright : (c) Hideyuki Tanaka 2009-2015
+ , (c) Dong Han 2020
+License : BSD3
+
+'Builder's to encode in MessagePack format.
+
+-}
+
+module Z.Data.MessagePack.Builder where
+
+import Control.Monad
+import Data.Bits
+import GHC.Int
+import Data.Word
+import Data.Primitive.PrimArray
+import GHC.Exts
+import GHC.Integer.GMP.Internals
+import Prelude hiding (map)
+import Z.Data.Array.Unaligned
+import qualified Z.Data.Text as T
+import qualified Z.Data.Builder as B
+import qualified Z.Data.Vector as V
+import Z.Data.MessagePack.Value hiding (value)
+
+value :: Value -> B.Builder ()
+{-# INLINABLE value #-}
+value v = case v of
+ Nil -> nil
+ Bool b -> bool b
+ Int n -> int n
+ Float f -> float f
+ Double d -> double d
+ Str t -> str t
+ Bin b -> bin b
+ Array a -> array value a
+ Map m -> map value value m
+ Ext b r -> ext b r
+
+nil :: B.Builder ()
+{-# INLINE nil #-}
+nil = B.word8 0xC0
+
+bool :: Bool -> B.Builder ()
+{-# INLINE bool #-}
+bool False = B.word8 0xC2
+bool True = B.word8 0xC3
+
+int :: Int64 -> B.Builder ()
+{-# INLINE int #-}
+int n
+ | -0x20 <= n && n < 0x80 = B.word8 (fromIntegral n)
+ | 0 <= n && n < 0x100 = B.word8 0xCC >> B.word8 (fromIntegral n)
+ | 0 <= n && n < 0x10000 = B.word8 0xCD >> B.encodePrimBE @Word16 (fromIntegral n)
+ | 0 <= n && n < 0x100000000 = B.word8 0xCE >> B.encodePrimBE @Word32 (fromIntegral n)
+ | 0 <= n = B.word8 0xCF >> B.encodePrimBE @Word64 (fromIntegral n)
+ | -0x80 <= n = B.word8 0xD0 >> B.word8 (fromIntegral n)
+ | -0x8000 <= n = B.word8 0xD1 >> B.encodePrimBE @Word16 (fromIntegral n)
+ | -0x80000000 <= n = B.word8 0xD2 >> B.encodePrimBE @Word32 (fromIntegral n)
+ | otherwise = B.word8 0xD3 >> B.encodePrimBE @Word64 (fromIntegral n)
+
+float :: Float -> B.Builder ()
+{-# INLINE float #-}
+float f = B.word8 0xCA >> B.encodePrimBE f
+
+double :: Double -> B.Builder ()
+{-# INLINE double #-}
+double d = B.word8 0xCB >> B.encodePrimBE d
+
+
+-- | Construct a scientific value, see 'scientific'.
+scientificValue :: Integer -> Int64 -> Value
+{-# INLINE scientificValue #-}
+scientificValue 0 _ = Ext 0x00 (V.pack [0x00, 0x00])
+scientificValue c e = Ext (if c > 0 then 0x00 else 0x01) . B.build $ do
+ int e
+ B.writeN (I# (word2Int# siz#)) $ \ (MutablePrimArray mba#) (I# off#) ->
+ void (exportIntegerToMutableByteArray c mba# (int2Word# off#) 1#)
+ where
+ siz# = sizeInBaseInteger c 256#
+
+-- | Write a scientific value in ext 0x00(positive) and 0x01(negative) format, e.g.
+--
+-- +--------+--------+--------+--------+
+-- | 0xD5 | 0x00 | 0x00 | 0x00 |
+-- +--------+--------+--------+--------+
+--
+--
+-- +--------+--------+--------+-----------------------------------------+---------------------------------------+
+-- | 0xC7 |XXXXXXXX| 0x00 | base10 exponent(MessagePack int format) | coefficient(big endian 256-base limbs |
+-- +--------+--------+--------+-----------------------------------------+---------------------------------------+
+--
+scientific :: Integer -> Int64 -> B.Builder ()
+{-# INLINE scientific #-}
+scientific 0 _ = B.encodePrim @(Word8, Word8, Word8, Word8) (0xD5, 0x00, 0x00, 0x00)
+scientific c e = do
+ case (I# (word2Int# siz#)) + intSiz e of
+ 1 -> B.word8 0xD4
+ 2 -> B.word8 0xD5
+ 4 -> B.word8 0xD6
+ 8 -> B.word8 0xD7
+ 16 -> B.word8 0xD8
+ siz' | siz' < 0x100 -> B.word8 0xC7 >> B.word8 (fromIntegral siz')
+ | siz' < 0x10000 -> B.word8 0xC8 >> B.encodePrimBE @Word16 (fromIntegral siz')
+ | otherwise -> B.word8 0xC9 >> B.encodePrimBE @Word32 (fromIntegral siz')
+ B.word8 (if c > 0 then 0x00 else 0x01)
+ int e
+ B.writeN (I# (word2Int# siz#)) $ \ (MutablePrimArray mba#) (I# off#) ->
+ void (exportIntegerToMutableByteArray c mba# (int2Word# off#) 1#)
+ where
+ siz# = sizeInBaseInteger c 256#
+ intSiz :: Int64 -> Int
+ intSiz n
+ | -0x20 <= n && n < 0x80 = 1
+ | 0 <= n && n < 0x100 = 2
+ | 0 <= n && n < 0x10000 = 3
+ | 0 <= n && n < 0x100000000 = 5
+ | 0 <= n = 9
+ | -0x80 <= n = 2
+ | -0x8000 <= n = 3
+ | -0x80000000 <= n = 5
+ | otherwise = 9
+
+-- | Construct a timestamp(seconds, nanoseconds) value.
+timestampValue :: Int64 -> Int32 -> Value
+{-# INLINE timestampValue #-}
+timestampValue s ns = Ext 0xFF (B.build $ B.encodePrimBE ns >> B.encodePrimBE s)
+
+-- | Write a timestamp(seconds, nanoseconds) in ext 0xFF format, e.g.
+timestamp :: Int64 -> Int32 -> B.Builder ()
+{-# INLINE timestamp #-}
+timestamp s ns = B.encodePrim @(Word8, Word8, Word8, (BE Int32), (BE Int64)) (0xC7, 0x0C, 0xFF, (BE ns), (BE s))
+
+str' :: String -> B.Builder ()
+{-# INLINE str' #-}
+str' = str . T.pack
+
+str :: T.Text -> B.Builder ()
+{-# INLINE str #-}
+str t = do
+ let bs = T.getUTF8Bytes t
+ case V.length bs of
+ len | len <= 31 -> B.word8 (0xA0 .|. fromIntegral len)
+ | len < 0x100 -> B.word8 0xD9 >> B.word8 (fromIntegral len)
+ | len < 0x10000 -> B.word8 0xDA >> B.encodePrimBE @Word16 (fromIntegral len)
+ | otherwise -> B.word8 0xDB >> B.encodePrimBE @Word32 (fromIntegral len)
+ B.bytes bs
+
+bin :: V.Bytes -> B.Builder ()
+{-# INLINE bin #-}
+bin bs = do
+ case V.length bs of
+ len | len < 0x100 -> B.word8 0xC4 >> B.word8 (fromIntegral len)
+ | len < 0x10000 -> B.word8 0xC5 >> B.encodePrimBE @Word16 (fromIntegral len)
+ | otherwise -> B.word8 0xC6 >> B.encodePrimBE @Word32 (fromIntegral len)
+ B.bytes bs
+
+array :: V.Vec v a => (a -> B.Builder ()) -> v a -> B.Builder ()
+{-# INLINE array #-}
+array p xs = do
+ arrayHeader (V.length xs)
+ V.traverseVec_ p xs
+
+array' :: (a -> B.Builder ()) -> [a] -> B.Builder ()
+{-# INLINE array' #-}
+array' p xs = do
+ arrayHeader (length xs)
+ mapM_ p xs
+
+arrayHeader :: Int -> B.Builder ()
+{-# INLINE arrayHeader #-}
+arrayHeader len
+ | len <= 15 = B.word8 (0x90 .|. fromIntegral len)
+ | len < 0x10000 = B.word8 0xDC >> B.encodePrimBE @Word16 (fromIntegral len)
+ | otherwise = B.word8 0xDD >> B.encodePrimBE @Word32 (fromIntegral len)
+
+map :: (a -> B.Builder ()) -> (b -> B.Builder ()) -> V.Vector (a, b) -> B.Builder ()
+{-# INLINE map #-}
+map p q xs = do
+ mapHeader (V.length xs)
+ V.traverseVec_ (\(a, b) -> p a >> q b) xs
+
+map' :: (a -> B.Builder ()) -> (b -> B.Builder ()) -> [(a, b)] -> B.Builder ()
+{-# INLINE map' #-}
+map' p q xs = do
+ mapHeader (length xs)
+ mapM_ (\(a, b) -> p a >> q b) xs
+
+mapHeader :: Int -> B.Builder ()
+{-# INLINE mapHeader #-}
+mapHeader len
+ | len <= 15 = B.word8 (0x80 .|. fromIntegral len)
+ | len < 0x10000 = B.word8 0xDE >> B.encodePrimBE @Word16 (fromIntegral len)
+ | otherwise = B.word8 0xDF >> B.encodePrimBE @Word32 (fromIntegral len)
+
+ext :: Word8 -> V.Bytes -> B.Builder ()
+{-# INLINABLE ext #-}
+ext typ dat = do
+ case V.length dat of
+ 1 -> B.word8 0xD4
+ 2 -> B.word8 0xD5
+ 4 -> B.word8 0xD6
+ 8 -> B.word8 0xD7
+ 16 -> B.word8 0xD8
+ len | len < 0x100 -> B.word8 0xC7 >> B.word8 (fromIntegral len)
+ | len < 0x10000 -> B.word8 0xC8 >> B.encodePrimBE @Word16 (fromIntegral len)
+ | otherwise -> B.word8 0xC9 >> B.encodePrimBE @Word32 (fromIntegral len)
+ B.word8 typ
+ B.bytes dat
diff --git a/Z/Data/MessagePack/Value.hs b/Z/Data/MessagePack/Value.hs
new file mode 100644
index 0000000..42e37f4
--- /dev/null
+++ b/Z/Data/MessagePack/Value.hs
@@ -0,0 +1,166 @@
+{- |
+Module : Z.Data.MessagePack.Value
+Description : MessagePack object definition and parser
+Copyright : (c) Hideyuki Tanaka 2009-2015
+ , (c) Dong Han 2020
+License : BSD3
+-}
+module Z.Data.MessagePack.Value(
+ -- * MessagePack Value
+ Value(..)
+ -- * parse into Message Value
+ , parseValue
+ , parseValue'
+ , parseValueChunks
+ , parseValueChunks'
+ -- * Value Parsers
+ , value
+ ) where
+
+import Control.DeepSeq
+import Control.Monad
+import Data.Bits
+import Data.Int
+import Data.Word
+import GHC.Generics (Generic)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Test.QuickCheck.Gen as Gen
+import Prelude hiding (map)
+import qualified Z.Data.Text as T
+import qualified Z.Data.Parser as P
+import qualified Z.Data.Vector as V
+
+
+-- | Representation of MessagePack data.
+data Value
+ = Bool !Bool -- ^ true or false
+ | Int {-# UNPACK #-} !Int64 -- ^ an integer
+ | Float {-# UNPACK #-} !Float -- ^ a floating point number
+ | Double {-# UNPACK #-} !Double -- ^ a floating point number
+ | Str {-# UNPACK #-} !T.Text -- ^ a UTF-8 string
+ | Bin {-# UNPACK #-} !V.Bytes -- ^ a byte array
+ | Array {-# UNPACK #-} !(V.Vector Value) -- ^ a sequence of objects
+ | Map {-# UNPACK #-} !(V.Vector (Value, Value)) -- ^ key-value pairs of objects
+ | Ext {-# UNPACK #-} !Word8 -- ^ type tag
+ {-# UNPACK #-} !V.Bytes -- ^ data payload
+ | Nil -- ^ nil
+ deriving (Show, Eq, Ord, Generic)
+ deriving anyclass T.Print
+
+instance NFData Value where
+ rnf obj = case obj of
+ Array a -> rnf a
+ Map m -> rnf m
+ _ -> ()
+
+instance Arbitrary Value where
+ arbitrary = Gen.sized $ \n -> Gen.oneof
+ [ Bool <$> arbitrary
+ , Int <$> negatives
+ , Float <$> arbitrary
+ , Double <$> arbitrary
+ , Str <$> arbitrary
+ , Bin <$> arbitrary
+ , Array <$> Gen.resize (n `div` 2) arbitrary
+ , Map <$> Gen.resize (n `div` 4) arbitrary
+ , Ext <$> arbitrary <*> arbitrary
+ , pure Nil
+ ]
+ where negatives = Gen.choose (minBound, -1)
+
+
+value :: P.Parser Value
+{-# INLINABLE value #-}
+value = do
+ tag <- P.anyWord8
+ case tag of
+ -- Nil
+ 0xC0 -> return Nil
+
+ -- Bool
+ 0xC2 -> return (Bool False)
+ 0xC3 -> return (Bool True)
+
+ -- Integer
+ c | c .&. 0x80 == 0x00 -> return (Int (fromIntegral c))
+ | c .&. 0xE0 == 0xE0 -> return (Int (fromIntegral (fromIntegral c :: Int8)))
+
+ 0xCC -> Int . fromIntegral <$> P.anyWord8
+ 0xCD -> Int . fromIntegral <$> P.decodePrimBE @Word16
+ 0xCE -> Int . fromIntegral <$> P.decodePrimBE @Word32
+ 0xCF -> Int . fromIntegral <$> P.decodePrimBE @Word64
+
+ 0xD0 -> Int . fromIntegral <$> P.decodePrim @Int8
+ 0xD1 -> Int . fromIntegral <$> P.decodePrimBE @Int16
+ 0xD2 -> Int . fromIntegral <$> P.decodePrimBE @Int32
+ 0xD3 -> Int . fromIntegral <$> P.decodePrimBE @Int64
+
+ -- Float
+ 0xCA -> Float <$> P.decodePrimBE @Float
+ -- Double
+ 0xCB -> Double <$> P.decodePrimBE @Double
+
+ -- String
+ t | t .&. 0xE0 == 0xA0 -> str (t .&. 0x1F)
+ 0xD9 -> str =<< P.anyWord8
+ 0xDA -> str =<< P.decodePrimBE @Word16
+ 0xDB -> str =<< P.decodePrimBE @Word32
+
+ -- Binary
+ 0xC4 -> bin =<< P.anyWord8
+ 0xC5 -> bin =<< P.decodePrimBE @Word16
+ 0xC6 -> bin =<< P.decodePrimBE @Word32
+
+ -- Array
+ t | t .&. 0xF0 == 0x90 -> array (t .&. 0x0F)
+ 0xDC -> array =<< P.decodePrimBE @Word16
+ 0xDD -> array =<< P.decodePrimBE @Word32
+
+ -- Map
+ t | t .&. 0xF0 == 0x80 -> map (t .&. 0x0F)
+ 0xDE -> map =<< P.decodePrimBE @Word16
+ 0xDF -> map =<< P.decodePrimBE @Word32
+
+ -- Ext
+ 0xD4 -> ext (1 :: Int)
+ 0xD5 -> ext (2 :: Int)
+ 0xD6 -> ext (4 :: Int)
+ 0xD7 -> ext (8 :: Int)
+ 0xD8 -> ext (16 :: Int)
+ 0xC7 -> ext =<< P.anyWord8
+ 0xC8 -> ext =<< P.decodePrimBE @Word16
+ 0xC9 -> ext =<< P.decodePrimBE @Word32
+
+ -- impossible
+ x -> P.fail' ("Z.Data.MessagePack: unknown tag " <> T.toText x)
+
+ where
+ str !l = do
+ bs <- P.take (fromIntegral l)
+ case T.validateMaybe bs of
+ Just t -> return (Str t)
+ _ -> P.fail' "Z.Data.MessagePack: illegal UTF8 Bytes"
+ bin !l = Bin <$> P.take (fromIntegral l)
+ array !l = Array . V.packN (fromIntegral l) <$> replicateM (fromIntegral l) value
+ map !l = Map . V.packN (fromIntegral l) <$> replicateM (fromIntegral l) ((,) <$> value <*> value)
+ ext !l = Ext <$> P.decodePrim <*> P.take (fromIntegral l)
+
+-- | Parse 'Value' without consuming trailing bytes.
+parseValue :: V.Bytes -> (V.Bytes, Either P.ParseError Value)
+{-# INLINE parseValue #-}
+parseValue = P.parse value
+
+-- | Parse 'Value', if there're bytes left, parsing will fail.
+parseValue' :: V.Bytes -> Either P.ParseError Value
+{-# INLINE parseValue' #-}
+parseValue' = P.parse' (value <* P.endOfInput)
+
+-- | Increamental parse 'Value' without consuming trailing bytes.
+parseValueChunks :: Monad m => m V.Bytes -> V.Bytes -> m (V.Bytes, Either P.ParseError Value)
+{-# INLINE parseValueChunks #-}
+parseValueChunks = P.parseChunks value
+
+-- | Increamental parse 'Value', if there're bytes left, parsing will fail.
+parseValueChunks' :: Monad m => m V.Bytes -> V.Bytes -> m (Either P.ParseError Value)
+{-# INLINE parseValueChunks' #-}
+parseValueChunks' mi inp = snd <$> P.parseChunks (value <* P.endOfInput) mi inp
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..ff51e4c
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+-- file test/Spec.hs
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/test/Z/Data/MessagePack/BaseSpec.hs b/test/Z/Data/MessagePack/BaseSpec.hs
new file mode 100644
index 0000000..7a75cd1
--- /dev/null
+++ b/test/Z/Data/MessagePack/BaseSpec.hs
@@ -0,0 +1,307 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Z.Data.MessagePack.BaseSpec where
+
+import qualified Data.List as L
+import Data.Word
+import Data.Int
+import Data.Either
+import GHC.Generics
+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 qualified Z.Data.Text as T
+import qualified Z.Data.Vector as V
+import qualified Z.Data.Builder as B
+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 Test.QuickCheck
+import Test.QuickCheck.Function
+import Test.QuickCheck.Instances
+import Test.QuickCheck.Property
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import qualified Z.Data.MessagePack as MessagePack
+import Z.Data.MessagePack (MessagePack(..), Value(..))
+
+
+data T a
+ = Nullary
+ | Unary Int
+ | Product T.Text (Maybe Char) a
+ | Record { testOne :: Double
+ , testTwo :: Maybe Bool
+ , testThree :: Maybe a
+ }
+
+ | RecordII { testFour :: Double }
+ | List [a]
+ deriving (Show, Eq, Generic, MessagePack)
+
+mid :: MessagePack a => a -> a
+mid = fromRight (error "decode failed") . MessagePack.decode' . MessagePack.encode
+
+intMid :: Int64 -> Int64
+intMid = mid
+
+ns :: UTCTime -> UTCTime
+ns = systemToUTCTime . utcToSystemTime
+
+encode' :: MessagePack a => a -> V.Bytes
+encode' = MessagePack.encode . toValue
+
+spec :: Spec
+spec = modifyMaxSuccess (*5) . modifyMaxSize (*5) $ do
+ describe "MessagePack Base instances" $ do
+
+ it "Nullary constructor are encoded as text" $
+ MessagePack.encode (Nullary :: T Integer) === B.build (do
+ B.word8 0xA7
+ "Nullary"
+ )
+
+ it "Unary constructor are encoded as single field object" $
+ MessagePack.encode (Unary 256 :: T ()) === B.build (do
+ B.word8 0x81
+ B.word8 0xA5
+ "Unary"
+ B.word8 0xCD
+ B.word8 0x01
+ B.word8 0x00
+ )
+
+ it "Product are encoded as array" $
+ MessagePack.encode (Product "ABC" (Just 'x') (256::Integer)) === B.build (do
+ B.word8 0x81
+ B.word8 0xA7
+ "Product"
+ B.word8 0x93
+ B.word8 0xA3
+ "ABC"
+ B.word8 0xA1
+ "x"
+ B.word8 0xC7
+ B.word8 0x03
+ B.word8 0x00
+ B.word8 0x00
+ B.word8 0x01
+ B.word8 0x00
+ )
+
+ it "Record are encoded as key values" $
+ MessagePack.encode (Record 0.123456 Nothing (Just (256::Integer))) === B.build (do
+ B.word8 0x81
+ B.word8 0xA6
+ "Record"
+ B.word8 0x83
+ B.word8 0xA7
+ "testOne"
+ B.word8 0xCB
+ B.encodePrimBE @Double 0.123456
+ B.word8 0xA7
+ "testTwo"
+ B.word8 0xC0
+ B.word8 0xA9
+ "testThree"
+ B.word8 0xC7
+ B.word8 0x03
+ B.word8 0x00
+ B.word8 0x00
+ B.word8 0x01
+ B.word8 0x00
+ )
+
+ it "Record are encoded as key values(single field)" $
+ MessagePack.encode (RecordII 0.123456 :: T ()) === B.build (do
+ B.word8 0x81
+ B.word8 0xA8
+ "RecordII"
+ B.word8 0x81
+ B.word8 0xA8
+ "testFour"
+ B.word8 0xCB
+ B.encodePrimBE @Double 0.123456
+ )
+
+ -- tests from MessagePack suit
+ it "int" $ property $ \(a :: Int ) -> a `shouldBe` mid a
+ it "int8" $ property $ \(a :: Int8 ) -> a `shouldBe` mid a
+ it "int16" $ property $ \(a :: Int16 ) -> a `shouldBe` mid a
+ it "int32" $ property $ \(a :: Int32 ) -> a `shouldBe` mid a
+ it "int64" $ property $ \(a :: Int64 ) -> a `shouldBe` mid a
+ it "word" $ property $ \(a :: Word ) -> a `shouldBe` mid a
+ it "word8" $ property $ \(a :: Word8 ) -> a `shouldBe` mid a
+ it "word16" $ property $ \(a :: Word16) -> a `shouldBe` mid a
+ it "word32" $ property $ \(a :: Word32) -> a `shouldBe` mid a
+ it "word64" $ property $ \(a :: Word64) -> a `shouldBe` mid a
+
+ it "()" $ property $ \(a :: ()) -> a `shouldBe` mid a
+ it "bool" $ property $ \(a :: Bool) -> a `shouldBe` mid a
+ it "float" $ property $ \(a :: Float) -> a `shouldBe` mid a
+ it "integer" $ property $ \(a :: Integer) -> a `shouldBe` mid a
+ it "double" $ property $ \(a :: Double) -> a `shouldBe` mid a
+ it "string" $ property $ \(a :: String) -> a `shouldBe` mid a
+ it "bytes" $ property $ \(a :: V.Bytes) -> a `shouldBe` mid a
+ it "primvector" $ property $ \(a :: V.PrimVector Int) -> a `shouldBe` mid a
+ it "vector" $ property $ \(a :: V.Vector [Integer]) -> a `shouldBe` mid a
+ it "maybe int" $ property $ \(a :: (Maybe Int)) -> a `shouldBe` mid a
+ it "[int]" $ property $ \(a :: [Int]) -> a `shouldBe` mid a
+ it "[string]" $ property $ \(a :: [String]) -> a `shouldBe` mid a
+ it "(int, int)" $ property $ \(a :: (Int, Int)) -> a `shouldBe` mid a
+ it "(int, int, int)" $ property $ \(a :: (Int, Int, Int)) -> a `shouldBe` mid a
+ it "(int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int)) -> a `shouldBe` mid a
+ it "(int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
+ it "(int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
+ it "(int, int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
+ it "(int, double)" $ property $ \(a :: (Int, Double)) -> a `shouldBe` mid a
+ it "[(int, double)]" $ property $ \(a :: [(Int, Double)]) -> a `shouldBe` mid a
+ it "[(string, string)]" $ property $ \(a :: [(String, String)]) -> a `shouldBe` mid a
+ it "HashMap Text Int" $ property $ \(a :: HM.HashMap T.Text Int) -> a `shouldBe` mid a
+ it "HashSet Text" $ property $ \(a :: HS.HashSet T.Text) -> a `shouldBe` mid a
+ it "Map Text Int" $ property $ \(a :: M.Map T.Text Int) -> a `shouldBe` mid a
+ it "IntMap Int" $ property $ \(a :: IM.IntMap Int) -> a `shouldBe` mid a
+ it "Set Int" $ property $ \(a :: Set.Set Int) -> a `shouldBe` mid a
+ it "IntSet" $ property $ \(a :: IS.IntSet) -> a `shouldBe` mid a
+ it "Seq Int" $ property $ \(a :: Seq.Seq Int) -> a `shouldBe` mid a
+ it "Tree Int" $ property $ \(a :: Tree.Tree Int) -> a `shouldBe` mid a
+ it "maybe int" $ property $ \(a :: Maybe Int) -> a `shouldBe` mid a
+ it "maybe nil" $ property $ \(a :: Maybe ()) -> a `shouldBe` mid a
+ it "maybe bool" $ property $ \(a :: Maybe Bool) -> a `shouldBe` mid a
+ it "maybe double" $ property $ \(a :: Maybe Double) -> a `shouldBe` mid a
+ it "maybe string" $ property $ \(a :: Maybe String) -> a `shouldBe` mid a
+ it "maybe bytes" $ property $ \ (a :: Maybe V.Bytes) -> a `shouldBe` mid a
+ it "maybe [int]" $ property $ \(a :: Maybe [Int]) -> a `shouldBe` mid a
+ it "maybe [string]" $ property $ \(a :: Maybe [String]) -> a `shouldBe` mid a
+ it "maybe (int, int)" $ property $ \(a :: Maybe (Int, Int)) -> a `shouldBe` mid a
+ it "maybe (int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int)) -> a `shouldBe` mid a
+ it "maybe (int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int)) -> a `shouldBe` mid a
+ it "maybe (int, int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
+ it "maybe [(int, double)]" $ property $ \(a :: Maybe [(Int, Double)]) -> a `shouldBe` mid a
+ it "maybe [(string, string)]" $ property $ \(a :: Maybe [(String, String)]) -> a `shouldBe` mid a
+ it "either int float" $ property $ \(a :: Either Int Float) -> a `shouldBe` mid a
+ it "Day" $ property $ \(a :: Day) -> a `shouldBe` mid a
+ it "DiffTime" $ property $ \(a :: DiffTime) -> a `shouldBe` mid a
+ it "LocalTime" $ property $ \(a :: LocalTime) -> a `shouldBe` mid a
+ it "NominalDiffTime" $ property $ \(a :: NominalDiffTime) -> a `shouldBe` mid a
+ it "TimeOfDay" $ property $ \(a :: TimeOfDay) -> a `shouldBe` mid a
+ it "UTCTime" $ property $ \(a :: UTCTime) -> ns a `shouldBe` mid (ns a)
+ it "SystemTime" $ property $ \(a :: SystemTime) -> a `shouldBe` mid a
+ it "CalendarDiffDays" $ property $ \(a :: CalendarDiffDays) -> a `shouldBe` mid a
+ it "DayOfWeek" $ property $ \(a :: DayOfWeek) -> a `shouldBe` mid a
+ it "CalendarDiffTime" $ property $ \(a :: CalendarDiffTime) -> a `shouldBe` mid a
+ it "arbitrary message" $ property $ \(a :: Value) -> a `shouldBe` mid a
+
+ describe "MessagePack Base instances encodeMessagePack == encodeMessagePack . toValue" $ do
+
+ it "Nullary constructor are encoded as text" $
+ MessagePack.encode (Nullary :: T Integer) ===
+ encode' (Nullary :: T Integer)
+
+ it "Unary constructor are encoded as single field object" $
+ MessagePack.encode (Unary 123456 :: T Integer) ===
+ encode' (Unary 123456 :: T Integer)
+
+ it "Product are encoded as array" $
+ MessagePack.encode (Product "ABC" (Just 'x') (123456::Integer)) ===
+ encode' (Product "ABC" (Just 'x') (123456::Integer))
+
+ it "Record are encoded as key values" $
+ MessagePack.encode (Record 0.123456 Nothing (Just (123456::Integer))) ===
+ encode' (Record 0.123456 Nothing (Just (123456::Integer)))
+
+ it "Record are encoded as key values(single field)" $
+ MessagePack.encode (RecordII 0.123456 :: T Integer) ===
+ encode' (RecordII 0.123456 :: T Integer)
+
+ it "List are encode as array" $
+ MessagePack.encode (List [Nullary
+ , Unary 123456
+ , (Product "ABC" (Just 'x') (123456::Integer))
+ , (Record 0.123456 Nothing (Just (123456::Integer)))]) ===
+ encode' (List [Nullary
+ , Unary 123456
+ , (Product "ABC" (Just 'x') (123456::Integer))
+ , (Record 0.123456 Nothing (Just (123456::Integer)))])
+
+ it "control characters are escaped" $
+ MessagePack.encode (T.pack $ map toEnum [0..0x1F]) ===
+ encode' (T.pack $ map toEnum [0..0x1F])
+
+ -- tests from MessagePack suit
+ it "int" $ property $ \(a :: Int ) -> encode' a === MessagePack.encode a
+ it "int8" $ property $ \(a :: Int8 ) -> encode' a === MessagePack.encode a
+ it "int16" $ property $ \(a :: Int16 ) -> encode' a === MessagePack.encode a
+ it "int32" $ property $ \(a :: Int32 ) -> encode' a === MessagePack.encode a
+ it "int64" $ property $ \(a :: Int64 ) -> encode' a === MessagePack.encode a
+ it "word" $ property $ \(a :: Word ) -> encode' a === MessagePack.encode a
+ it "word8" $ property $ \(a :: Word8 ) -> encode' a === MessagePack.encode a
+ it "word16" $ property $ \(a :: Word16) -> encode' a === MessagePack.encode a
+ it "word32" $ property $ \(a :: Word32) -> encode' a === MessagePack.encode a
+ it "word64" $ property $ \(a :: Word64) -> encode' a === MessagePack.encode a
+
+ it "()" $ property $ \(a :: ()) -> encode' a === MessagePack.encode a
+ it "bool" $ property $ \(a :: Bool) -> encode' a === MessagePack.encode a
+ it "float" $ property $ \(a :: Float) -> encode' a === MessagePack.encode a
+ it "double" $ property $ \(a :: Double) -> encode' a === MessagePack.encode a
+ it "integer" $ property $ \(a :: Integer) -> encode' a === MessagePack.encode a
+ it "string" $ property $ \(a :: String) -> encode' a === MessagePack.encode a
+ it "bytes" $ property $ \(a :: V.Bytes) -> encode' a === MessagePack.encode a
+ it "primvector" $ property $ \(a :: V.PrimVector Int) -> encode' a === MessagePack.encode a
+ it "vector" $ property $ \(a :: V.Vector [Integer]) -> encode' a === MessagePack.encode a
+ it "maybe int" $ property $ \(a :: (Maybe Int)) -> encode' a === MessagePack.encode a
+ it "[int]" $ property $ \(a :: [Int]) -> encode' a === MessagePack.encode a
+ it "[string]" $ property $ \(a :: [String]) -> encode' a === MessagePack.encode a
+ it "(int, int)" $ property $ \(a :: (Int, Int)) -> encode' a === MessagePack.encode a
+ it "(int, int, int)" $ property $ \(a :: (Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "(int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "(int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "(int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "(int, int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "(int, double)" $ property $ \(a :: (Int, Double)) -> encode' a === MessagePack.encode a
+ it "[(int, double)]" $ property $ \(a :: [(Int, Double)]) -> encode' a === MessagePack.encode a
+ it "[(string, string)]" $ property $ \(a :: [(String, String)]) -> encode' a === MessagePack.encode a
+ it "HashMap Text Int" $ property $ \(a :: HM.HashMap T.Text Int) -> encode' a === MessagePack.encode a
+ it "HashSet Text" $ property $ \(a :: HS.HashSet T.Text) -> encode' a === MessagePack.encode a
+ it "Map Text Int" $ property $ \(a :: M.Map T.Text Int) -> encode' a === MessagePack.encode a
+ it "IntMap Int" $ property $ \(a :: IM.IntMap Int) -> encode' a === MessagePack.encode a
+ it "Set Int" $ property $ \(a :: Set.Set Int) -> encode' a === MessagePack.encode a
+ it "IntSet" $ property $ \(a :: IS.IntSet) -> encode' a === MessagePack.encode a
+ it "Seq Int" $ property $ \(a :: Seq.Seq Int) -> encode' a === MessagePack.encode a
+ it "Tree Int" $ property $ \(a :: Tree.Tree Int) -> encode' a === MessagePack.encode a
+ it "maybe int" $ property $ \(a :: Maybe Int) -> encode' a === MessagePack.encode a
+ it "maybe nil" $ property $ \(a :: Maybe ()) -> encode' a === MessagePack.encode a
+ it "maybe bool" $ property $ \(a :: Maybe Bool) -> encode' a === MessagePack.encode a
+ it "maybe double" $ property $ \(a :: Maybe Double) -> encode' a === MessagePack.encode a
+ it "maybe string" $ property $ \(a :: Maybe String) -> encode' a === MessagePack.encode a
+ it "maybe bytes" $ property $ \ (a :: Maybe V.Bytes) -> encode' a === MessagePack.encode a
+ it "maybe [int]" $ property $ \(a :: Maybe [Int]) -> encode' a === MessagePack.encode a
+ it "maybe [string]" $ property $ \(a :: Maybe [String]) -> encode' a === MessagePack.encode a
+ it "maybe (int, int)" $ property $ \(a :: Maybe (Int, Int)) -> encode' a === MessagePack.encode a
+ it "maybe (int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "maybe (int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "maybe (int, int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> encode' a === MessagePack.encode a
+ it "maybe [(int, double)]" $ property $ \(a :: Maybe [(Int, Double)]) -> encode' a === MessagePack.encode a
+ it "maybe [(string, string)]" $ property $ \(a :: Maybe [(String, String)]) -> encode' a === MessagePack.encode a
+ it "either int float" $ property $ \(a :: Either Int Float) -> encode' a === MessagePack.encode a
+ it "Day" $ property $ \(a :: Day) -> encode' a === MessagePack.encode a
+ it "DiffTime" $ property $ \(a :: DiffTime) -> encode' a === MessagePack.encode a
+ it "LocalTime" $ property $ \(a :: LocalTime) -> encode' a === MessagePack.encode a
+ it "NominalDiffTime" $ property $ \(a :: NominalDiffTime) -> encode' a === MessagePack.encode a
+ it "TimeOfDay" $ property $ \(a :: TimeOfDay) -> encode' a === MessagePack.encode a
+ it "UTCTime" $ property $ \(a :: UTCTime) -> encode' a === MessagePack.encode a
+ it "SystemTime" $ property $ \(a :: SystemTime) -> encode' a === MessagePack.encode a
+ it "CalendarDiffDays" $ property $ \(a :: CalendarDiffDays) -> encode' a === MessagePack.encode a
+ it "DayOfWeek" $ property $ \(a :: DayOfWeek) -> encode' a === MessagePack.encode a
+ it "CalendarDiffTime" $ property $ \(a :: CalendarDiffTime) -> encode' a === MessagePack.encode a
+ it "arbitrary message" $ property $ \(a :: Value) -> encode' a === MessagePack.encode a
generated by cgit v0.10.2 at 2021-03-01 07:05:30 (GMT)