diff --git a/data-msgpack.cabal b/data-msgpack.cabal --- a/data-msgpack.cabal +++ b/data-msgpack.cabal @@ -1,5 +1,5 @@ name: data-msgpack -version: 0.0.5 +version: 0.0.6 synopsis: A Haskell implementation of MessagePack homepage: http://msgpack.org/ license: BSD3 diff --git a/src/Data/MessagePack/Class.hs b/src/Data/MessagePack/Class.hs --- a/src/Data/MessagePack/Class.hs +++ b/src/Data/MessagePack/Class.hs @@ -81,22 +81,36 @@ fromInt :: Integral a => Int64 -> a fromInt = fromIntegral +toWord :: Integral a => a -> Word64 +toWord = fromIntegral + +fromWord :: Integral a => Word64 -> a +fromWord = fromIntegral + instance MessagePack Int64 where - toObject = ObjectInt + toObject i + | i < 0 = ObjectInt i + | otherwise = ObjectWord $ toWord i fromObject = \case - ObjectInt n -> return n - _ -> fail "invalid encoding for integer type" + ObjectInt n -> return n + ObjectWord n -> return $ toInt n + _ -> fail "invalid encoding for integer type" +instance MessagePack Word64 where + toObject = ObjectWord + fromObject = \case + ObjectWord n -> return n + _ -> fail "invalid encoding for integer type" + instance MessagePack Int where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } instance MessagePack Int8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } instance MessagePack Int16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } instance MessagePack Int32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } -instance MessagePack Word where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } -instance MessagePack Word8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } -instance MessagePack Word16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } -instance MessagePack Word32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } -instance MessagePack Word64 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } +instance MessagePack Word8 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } +instance MessagePack Word16 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } +instance MessagePack Word32 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } -- Core instances. @@ -106,8 +120,9 @@ fromObject = return instance MessagePack () where - toObject _ = ObjectArray [] + toObject _ = ObjectNil fromObject = \case + ObjectNil -> return () ObjectArray [] -> return () _ -> fail "invalid encoding for ()" @@ -121,6 +136,7 @@ toObject = ObjectFloat fromObject = \case ObjectInt n -> return $ fromIntegral n + ObjectWord n -> return $ fromIntegral n ObjectFloat f -> return f ObjectDouble d -> return $ realToFrac d _ -> fail "invalid encoding for Float" @@ -129,6 +145,7 @@ toObject = ObjectDouble fromObject = \case ObjectInt n -> return $ fromIntegral n + ObjectWord n -> return $ fromIntegral n ObjectFloat f -> return $ realToFrac f ObjectDouble d -> return d _ -> fail "invalid encoding for Double" diff --git a/src/Data/MessagePack/Generic.hs b/src/Data/MessagePack/Generic.hs --- a/src/Data/MessagePack/Generic.hs +++ b/src/Data/MessagePack/Generic.hs @@ -37,8 +37,8 @@ size = unTagged (sumSize :: Tagged (a :+: b) Word64) gFromObject = \case - ObjectInt code -> checkSumFromObject0 size (fromIntegral code) - o -> fromObject o >>= uncurry (checkSumFromObject size) + ObjectWord code -> checkSumFromObject0 size (fromIntegral code) + o -> fromObject o >>= uncurry (checkSumFromObject size) where size = unTagged (sumSize :: Tagged (a :+: b) Word64) diff --git a/src/Data/MessagePack/Get.hs b/src/Data/MessagePack/Get.hs --- a/src/Data/MessagePack/Get.hs +++ b/src/Data/MessagePack/Get.hs @@ -19,6 +19,7 @@ ( getNil , getBool , getInt + , getWord , getFloat , getDouble , getStr @@ -39,7 +40,7 @@ import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Word (Word8) +import Data.Word (Word64, Word8) getNil :: Get () getNil = tag 0xC0 @@ -52,18 +53,23 @@ getInt :: Get Int64 getInt = getWord8 >>= \case + c | c .&. 0xE0 == 0xE0 -> + return $ fromIntegral (fromIntegral c :: Int8) + 0xD0 -> fromIntegral <$> getInt8 + 0xD1 -> fromIntegral <$> getInt16be + 0xD2 -> fromIntegral <$> getInt32be + 0xD3 -> fromIntegral <$> getInt64be + _ -> empty + +getWord :: Get Word64 +getWord = + getWord8 >>= \case c | c .&. 0x80 == 0x00 -> return $ fromIntegral c - | c .&. 0xE0 == 0xE0 -> - return $ fromIntegral (fromIntegral c :: Int8) 0xCC -> fromIntegral <$> getWord8 0xCD -> fromIntegral <$> getWord16be 0xCE -> fromIntegral <$> getWord32be 0xCF -> fromIntegral <$> getWord64be - 0xD0 -> fromIntegral <$> getInt8 - 0xD1 -> fromIntegral <$> getInt16be - 0xD2 -> fromIntegral <$> getInt32be - 0xD3 -> fromIntegral <$> getInt64be _ -> empty getFloat :: Get Float diff --git a/src/Data/MessagePack/Object.hs b/src/Data/MessagePack/Object.hs --- a/src/Data/MessagePack/Object.hs +++ b/src/Data/MessagePack/Object.hs @@ -14,7 +14,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable) -import Data.Word (Word8) +import Data.Word (Word64, Word8) import GHC.Generics (Generic) import Prelude hiding (putStr) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) @@ -31,7 +31,9 @@ | ObjectBool !Bool -- ^ represents true or false | ObjectInt {-# UNPACK #-} !Int64 - -- ^ represents an integer + -- ^ represents a negative integer + | ObjectWord {-# UNPACK #-} !Word64 + -- ^ represents a positive integer | ObjectFloat {-# UNPACK #-} !Float -- ^ represents a floating point number | ObjectDouble {-# UNPACK #-} !Double @@ -61,6 +63,7 @@ ObjectNil <$ getNil <|> ObjectBool <$> getBool <|> ObjectInt <$> getInt + <|> ObjectWord <$> getWord <|> ObjectFloat <$> getFloat <|> ObjectDouble <$> getDouble <|> ObjectStr <$> getStr @@ -74,6 +77,7 @@ ObjectNil -> putNil ObjectBool b -> putBool b ObjectInt n -> putInt n + ObjectWord n -> putWord n ObjectFloat f -> putFloat f ObjectDouble d -> putDouble d ObjectStr t -> putStr t @@ -87,7 +91,8 @@ arbitrary = Gen.sized $ \n -> Gen.oneof [ return ObjectNil , ObjectBool <$> arbitrary - , ObjectInt <$> arbitrary + , ObjectInt <$> negatives + , ObjectWord <$> arbitrary , ObjectFloat <$> arbitrary , ObjectDouble <$> arbitrary , ObjectStr <$> arbitrary @@ -96,6 +101,7 @@ , ObjectMap <$> Gen.resize (n `div` 4) arbitrary , ObjectExt <$> arbitrary <*> arbitrary ] + where negatives = Gen.choose (minBound, -1) instance Arbitrary S.ByteString where arbitrary = S.pack <$> arbitrary diff --git a/src/Data/MessagePack/Put.hs b/src/Data/MessagePack/Put.hs --- a/src/Data/MessagePack/Put.hs +++ b/src/Data/MessagePack/Put.hs @@ -17,6 +17,7 @@ ( putNil , putBool , putInt + , putWord , putFloat , putDouble , putStr @@ -35,7 +36,7 @@ import Data.Int (Int64) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Word (Word8) +import Data.Word (Word64, Word8) import Prelude hiding (putStr) @@ -66,6 +67,19 @@ putWord8 0xD2 >> putWord32be (fromIntegral n) | otherwise = putWord8 0xD3 >> putWord64be (fromIntegral n) + +putWord :: Word64 -> Put +putWord n + | n < 0x80 = + putWord8 (fromIntegral n) + | n < 0x100 = + putWord8 0xCC >> putWord8 (fromIntegral n) + | n < 0x10000 = + putWord8 0xCD >> putWord16be (fromIntegral n) + | n < 0x100000000 = + putWord8 0xCE >> putWord32be (fromIntegral n) + | otherwise = + putWord8 0xCF >> putWord64be n putFloat :: Float -> Put putFloat f = do