diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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