mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-10-21 23:56:55 +02:00
haskell: refactoring
This commit is contained in:
tanakh
@@ -40,166 +40,113 @@ class ObjectGet a where
|
||||
-- | Deserialize a value
|
||||
get :: A.Parser a
|
||||
|
||||
instance ObjectGet Object where
|
||||
get =
|
||||
A.choice
|
||||
[ liftM ObjectInteger get
|
||||
, liftM (\() -> ObjectNil) get
|
||||
, liftM ObjectBool get
|
||||
, liftM ObjectDouble get
|
||||
, liftM ObjectRAW get
|
||||
, liftM ObjectArray get
|
||||
, liftM ObjectMap get
|
||||
]
|
||||
|
||||
instance ObjectGet Int where
|
||||
get = parseInt
|
||||
get = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0x80 == 0x00 ->
|
||||
return $ fromIntegral c
|
||||
_ | c .&. 0xE0 == 0xE0 ->
|
||||
return $ fromIntegral (fromIntegral c :: Int8)
|
||||
0xCC ->
|
||||
return . fromIntegral =<< A.anyWord8
|
||||
0xCD ->
|
||||
return . fromIntegral =<< parseUint16
|
||||
0xCE ->
|
||||
return . fromIntegral =<< parseUint32
|
||||
0xCF ->
|
||||
return . fromIntegral =<< parseUint64
|
||||
0xD0 ->
|
||||
return . fromIntegral =<< parseInt8
|
||||
0xD1 ->
|
||||
return . fromIntegral =<< parseInt16
|
||||
0xD2 ->
|
||||
return . fromIntegral =<< parseInt32
|
||||
0xD3 ->
|
||||
return . fromIntegral =<< parseInt64
|
||||
_ ->
|
||||
fail $ printf "invlid integer tag: 0x%02X" c
|
||||
|
||||
instance ObjectGet () where
|
||||
get = parseNil
|
||||
get = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
0xC0 ->
|
||||
return ()
|
||||
_ ->
|
||||
fail $ printf "invlid nil tag: 0x%02X" c
|
||||
|
||||
instance ObjectGet Bool where
|
||||
get = parseBool
|
||||
get = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
0xC3 ->
|
||||
return True
|
||||
0xC2 ->
|
||||
return False
|
||||
_ ->
|
||||
fail $ printf "invlid bool tag: 0x%02X" c
|
||||
|
||||
instance ObjectGet Double where
|
||||
get = parseDouble
|
||||
get = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
0xCA ->
|
||||
return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4
|
||||
0xCB ->
|
||||
return . runGet getFloat64be . toLBS =<< A.take 8
|
||||
_ ->
|
||||
fail $ printf "invlid double tag: 0x%02X" c
|
||||
|
||||
instance ObjectGet B.ByteString where
|
||||
get = parseRAW
|
||||
get = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xE0 == 0xA0 ->
|
||||
A.take . fromIntegral $ c .&. 0x1F
|
||||
0xDA ->
|
||||
A.take . fromIntegral =<< parseUint16
|
||||
0xDB ->
|
||||
A.take . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid raw tag: 0x%02X" c
|
||||
|
||||
instance ObjectGet a => ObjectGet [a] where
|
||||
get = parseArray
|
||||
get = parseArray (flip replicateM get)
|
||||
|
||||
instance ObjectGet a => ObjectGet (V.Vector a) where
|
||||
get = parseArrayVector
|
||||
get = parseArray (flip V.replicateM get)
|
||||
|
||||
parseArray :: (Int -> A.Parser a) -> A.Parser a
|
||||
parseArray aget = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xF0 == 0x90 ->
|
||||
aget . fromIntegral $ c .&. 0x0F
|
||||
0xDC ->
|
||||
aget . fromIntegral =<< parseUint16
|
||||
0xDD ->
|
||||
aget . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid array tag: 0x%02X" c
|
||||
|
||||
instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where
|
||||
get = parseMap
|
||||
get = parseMap (flip replicateM parsePair)
|
||||
|
||||
instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where
|
||||
get = parseMapVector
|
||||
|
||||
instance ObjectGet Object where
|
||||
get = parseObject
|
||||
|
||||
parseInt :: A.Parser Int
|
||||
parseInt = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0x80 == 0x00 ->
|
||||
return $ fromIntegral c
|
||||
_ | c .&. 0xE0 == 0xE0 ->
|
||||
return $ fromIntegral (fromIntegral c :: Int8)
|
||||
0xCC ->
|
||||
return . fromIntegral =<< A.anyWord8
|
||||
0xCD ->
|
||||
return . fromIntegral =<< parseUint16
|
||||
0xCE ->
|
||||
return . fromIntegral =<< parseUint32
|
||||
0xCF ->
|
||||
return . fromIntegral =<< parseUint64
|
||||
0xD0 ->
|
||||
return . fromIntegral =<< parseInt8
|
||||
0xD1 ->
|
||||
return . fromIntegral =<< parseInt16
|
||||
0xD2 ->
|
||||
return . fromIntegral =<< parseInt32
|
||||
0xD3 ->
|
||||
return . fromIntegral =<< parseInt64
|
||||
_ ->
|
||||
fail $ printf "invlid integer tag: 0x%02X" c
|
||||
|
||||
parseNil :: A.Parser ()
|
||||
parseNil = do
|
||||
_ <- A.word8 0xC0
|
||||
return ()
|
||||
|
||||
parseBool :: A.Parser Bool
|
||||
parseBool = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
0xC3 ->
|
||||
return True
|
||||
0xC2 ->
|
||||
return False
|
||||
_ ->
|
||||
fail $ printf "invlid bool tag: 0x%02X" c
|
||||
|
||||
parseDouble :: A.Parser Double
|
||||
parseDouble = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
0xCA ->
|
||||
return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4
|
||||
0xCB ->
|
||||
return . runGet getFloat64be . toLBS =<< A.take 8
|
||||
_ ->
|
||||
fail $ printf "invlid double tag: 0x%02X" c
|
||||
|
||||
parseRAW :: A.Parser B.ByteString
|
||||
parseRAW = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xE0 == 0xA0 ->
|
||||
A.take . fromIntegral $ c .&. 0x1F
|
||||
0xDA ->
|
||||
A.take . fromIntegral =<< parseUint16
|
||||
0xDB ->
|
||||
A.take . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid raw tag: 0x%02X" c
|
||||
|
||||
parseArray :: ObjectGet a => A.Parser [a]
|
||||
parseArray = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xF0 == 0x90 ->
|
||||
flip replicateM get . fromIntegral $ c .&. 0x0F
|
||||
0xDC ->
|
||||
flip replicateM get . fromIntegral =<< parseUint16
|
||||
0xDD ->
|
||||
flip replicateM get . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid array tag: 0x%02X" c
|
||||
|
||||
parseArrayVector :: ObjectGet a => A.Parser (V.Vector a)
|
||||
parseArrayVector = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xF0 == 0x90 ->
|
||||
flip V.replicateM get . fromIntegral $ c .&. 0x0F
|
||||
0xDC ->
|
||||
flip V.replicateM get . fromIntegral =<< parseUint16
|
||||
0xDD ->
|
||||
flip V.replicateM get . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid array tag: 0x%02X" c
|
||||
|
||||
parseMap :: (ObjectGet k, ObjectGet v) => A.Parser [(k, v)]
|
||||
parseMap = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xF0 == 0x80 ->
|
||||
flip replicateM parsePair . fromIntegral $ c .&. 0x0F
|
||||
0xDE ->
|
||||
flip replicateM parsePair . fromIntegral =<< parseUint16
|
||||
0xDF ->
|
||||
flip replicateM parsePair . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid map tag: 0x%02X" c
|
||||
|
||||
parseMapVector :: (ObjectGet k, ObjectGet v) => A.Parser (V.Vector (k, v))
|
||||
parseMapVector = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xF0 == 0x80 ->
|
||||
flip V.replicateM parsePair . fromIntegral $ c .&. 0x0F
|
||||
0xDE ->
|
||||
flip V.replicateM parsePair . fromIntegral =<< parseUint16
|
||||
0xDF ->
|
||||
flip V.replicateM parsePair . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid map tag: 0x%02X" c
|
||||
|
||||
parseObject :: A.Parser Object
|
||||
parseObject =
|
||||
A.choice
|
||||
[ liftM ObjectInteger parseInt
|
||||
, liftM (const ObjectNil) parseNil
|
||||
, liftM ObjectBool parseBool
|
||||
, liftM ObjectDouble parseDouble
|
||||
, liftM ObjectRAW parseRAW
|
||||
, liftM ObjectArray parseArray
|
||||
, liftM ObjectMap parseMap
|
||||
]
|
||||
get = parseMap (flip V.replicateM parsePair)
|
||||
|
||||
parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)
|
||||
parsePair = do
|
||||
@@ -207,6 +154,19 @@ parsePair = do
|
||||
b <- get
|
||||
return (a, b)
|
||||
|
||||
parseMap :: (Int -> A.Parser a) -> A.Parser a
|
||||
parseMap aget = do
|
||||
c <- A.anyWord8
|
||||
case c of
|
||||
_ | c .&. 0xF0 == 0x80 ->
|
||||
aget . fromIntegral $ c .&. 0x0F
|
||||
0xDE ->
|
||||
aget . fromIntegral =<< parseUint16
|
||||
0xDF ->
|
||||
aget . fromIntegral =<< parseUint32
|
||||
_ ->
|
||||
fail $ printf "invlid map tag: 0x%02X" c
|
||||
|
||||
parseUint16 :: A.Parser Word16
|
||||
parseUint16 = do
|
||||
b0 <- A.anyWord8
|
||||
|
||||
@@ -35,168 +35,120 @@ class ObjectPut a where
|
||||
put :: a -> Put
|
||||
|
||||
instance ObjectPut Object where
|
||||
put = putObject
|
||||
put obj =
|
||||
case obj of
|
||||
ObjectInteger n ->
|
||||
put n
|
||||
ObjectNil ->
|
||||
put ()
|
||||
ObjectBool b ->
|
||||
put b
|
||||
ObjectDouble d ->
|
||||
put d
|
||||
ObjectRAW raw ->
|
||||
put raw
|
||||
ObjectArray arr ->
|
||||
put arr
|
||||
ObjectMap m ->
|
||||
put m
|
||||
|
||||
instance ObjectPut Int where
|
||||
put = putInteger
|
||||
put n =
|
||||
case n of
|
||||
_ | n >= 0 && n <= 127 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -32 && n <= -1 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100 -> do
|
||||
putWord8 0xCC
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x10000 -> do
|
||||
putWord8 0xCD
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100000000 -> do
|
||||
putWord8 0xCE
|
||||
putWord32be $ fromIntegral n
|
||||
_ | n >= 0 -> do
|
||||
putWord8 0xCF
|
||||
putWord64be $ fromIntegral n
|
||||
_ | n >= -0x80 -> do
|
||||
putWord8 0xD0
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -0x8000 -> do
|
||||
putWord8 0xD1
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= -0x80000000 -> do
|
||||
putWord8 0xD2
|
||||
putWord32be $ fromIntegral n
|
||||
_ -> do
|
||||
putWord8 0xD3
|
||||
putWord64be $ fromIntegral n
|
||||
|
||||
instance ObjectPut () where
|
||||
put _ = putNil
|
||||
put _ =
|
||||
putWord8 0xC0
|
||||
|
||||
instance ObjectPut Bool where
|
||||
put = putBool
|
||||
put True = putWord8 0xC3
|
||||
put False = putWord8 0xC2
|
||||
|
||||
instance ObjectPut Double where
|
||||
put = putDouble
|
||||
put d = do
|
||||
putWord8 0xCB
|
||||
putFloat64be d
|
||||
|
||||
instance ObjectPut B.ByteString where
|
||||
put = putRAW
|
||||
put bs = do
|
||||
case len of
|
||||
_ | len <= 31 -> do
|
||||
putWord8 $ 0xA0 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDA
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDB
|
||||
putWord32be $ fromIntegral len
|
||||
putByteString bs
|
||||
where
|
||||
len = B.length bs
|
||||
|
||||
instance ObjectPut a => ObjectPut [a] where
|
||||
put = putArray
|
||||
put = putArray length (mapM_ put)
|
||||
|
||||
instance ObjectPut a => ObjectPut (V.Vector a) where
|
||||
put = putArrayVector
|
||||
put = putArray V.length (V.mapM_ put)
|
||||
|
||||
putArray :: (a -> Int) -> (a -> Put) -> a -> Put
|
||||
putArray lf pf arr = do
|
||||
case lf arr of
|
||||
len | len <= 15 ->
|
||||
putWord8 $ 0x90 .|. fromIntegral len
|
||||
len | len < 0x10000 -> do
|
||||
putWord8 0xDC
|
||||
putWord16be $ fromIntegral len
|
||||
len -> do
|
||||
putWord8 0xDD
|
||||
putWord32be $ fromIntegral len
|
||||
pf arr
|
||||
|
||||
instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
|
||||
put = putMap
|
||||
put = putMap length (mapM_ putPair)
|
||||
|
||||
instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where
|
||||
put = putMapVector
|
||||
put = putMap V.length (V.mapM_ putPair)
|
||||
|
||||
putObject :: Object -> Put
|
||||
putObject obj =
|
||||
case obj of
|
||||
ObjectInteger n ->
|
||||
putInteger n
|
||||
ObjectNil ->
|
||||
putNil
|
||||
ObjectBool b ->
|
||||
putBool b
|
||||
ObjectDouble d ->
|
||||
putDouble d
|
||||
ObjectRAW raw ->
|
||||
putRAW raw
|
||||
ObjectArray arr ->
|
||||
putArray arr
|
||||
ObjectMap m ->
|
||||
putMap m
|
||||
putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put
|
||||
putPair (a, b) = put a >> put b
|
||||
|
||||
putInteger :: Int -> Put
|
||||
putInteger n =
|
||||
case n of
|
||||
_ | n >= 0 && n <= 127 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -32 && n <= -1 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100 -> do
|
||||
putWord8 0xCC
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x10000 -> do
|
||||
putWord8 0xCD
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100000000 -> do
|
||||
putWord8 0xCE
|
||||
putWord32be $ fromIntegral n
|
||||
_ | n >= 0 -> do
|
||||
putWord8 0xCF
|
||||
putWord64be $ fromIntegral n
|
||||
_ | n >= -0x80 -> do
|
||||
putWord8 0xD0
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -0x8000 -> do
|
||||
putWord8 0xD1
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= -0x80000000 -> do
|
||||
putWord8 0xD2
|
||||
putWord32be $ fromIntegral n
|
||||
_ -> do
|
||||
putWord8 0xD3
|
||||
putWord64be $ fromIntegral n
|
||||
|
||||
putNil :: Put
|
||||
putNil = putWord8 0xC0
|
||||
|
||||
putBool :: Bool -> Put
|
||||
putBool True = putWord8 0xC3
|
||||
putBool False = putWord8 0xC2
|
||||
|
||||
putDouble :: Double -> Put
|
||||
putDouble d = do
|
||||
putWord8 0xCB
|
||||
putFloat64be d
|
||||
|
||||
putRAW :: B.ByteString -> Put
|
||||
putRAW bs = do
|
||||
case len of
|
||||
_ | len <= 31 -> do
|
||||
putWord8 $ 0xA0 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDA
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDB
|
||||
putWord32be $ fromIntegral len
|
||||
putByteString bs
|
||||
where
|
||||
len = B.length bs
|
||||
|
||||
putArray :: ObjectPut a => [a] -> Put
|
||||
putArray arr = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x90 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDC
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDD
|
||||
putWord32be $ fromIntegral len
|
||||
mapM_ put arr
|
||||
where
|
||||
len = length arr
|
||||
|
||||
putArrayVector :: ObjectPut a => V.Vector a -> Put
|
||||
putArrayVector arr = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x90 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDC
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDD
|
||||
putWord32be $ fromIntegral len
|
||||
V.mapM_ put arr
|
||||
where
|
||||
len = V.length arr
|
||||
|
||||
putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
|
||||
putMap m = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putMap :: (a -> Int) -> (a -> Put) -> a -> Put
|
||||
putMap lf pf m = do
|
||||
case lf m of
|
||||
len | len <= 15 ->
|
||||
putWord8 $ 0x80 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
len | len < 0x10000 -> do
|
||||
putWord8 0xDE
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
len -> do
|
||||
putWord8 0xDF
|
||||
putWord32be $ fromIntegral len
|
||||
mapM_ (\(k, v) -> put k >> put v) m
|
||||
where
|
||||
len = length m
|
||||
|
||||
putMapVector :: (ObjectPut k, ObjectPut v) => V.Vector (k, v) -> Put
|
||||
putMapVector m = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x80 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDE
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDF
|
||||
putWord32be $ fromIntegral len
|
||||
V.mapM_ (\(k, v) -> put k >> put v) m
|
||||
where
|
||||
len = V.length m
|
||||
pf m
|
||||
|
||||
Reference in New Issue
Block a user