mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-03-21 06:11:18 +01:00
MessagePack for Haskell moved to https://github.com/msgpack/msgpack-haskell
This commit is contained in:
FURUHASHI Sadayuki
parent
834d5a0e72
commit
b2839ac78b
@ -1,24 +0,0 @@
|
|||||||
Copyright (c) 2009-2010, Hideyuki Tanaka
|
|
||||||
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 the Hideyuki Tanaka nor the
|
|
||||||
names of its contributors may be used to endorse or promote products
|
|
||||||
derived from this software without specific prior written permission.
|
|
||||||
|
|
||||||
THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''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 <copyright holder> 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.
|
|
||||||
@ -0,0 +1 @@
|
|||||||
|
MessagePack for Haskell moved to https://github.com/msgpack/msgpack-haskell.
|
||||||
@ -1,3 +0,0 @@
|
|||||||
#!/usr/bin/env runhaskell
|
|
||||||
> import Distribution.Simple
|
|
||||||
> main = defaultMain
|
|
||||||
@ -1,50 +0,0 @@
|
|||||||
Name: msgpack
|
|
||||||
Version: 0.6.4
|
|
||||||
Synopsis: A Haskell implementation of MessagePack
|
|
||||||
Description:
|
|
||||||
A Haskell implementation of MessagePack <http://msgpack.org/>
|
|
||||||
|
|
||||||
License: BSD3
|
|
||||||
License-File: LICENSE
|
|
||||||
Copyright: Copyright (c) 2009-2011, Hideyuki Tanaka
|
|
||||||
Category: Data
|
|
||||||
Author: Hideyuki Tanaka
|
|
||||||
Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
|
|
||||||
Homepage: http://github.com/msgpack/msgpack
|
|
||||||
Stability: Experimental
|
|
||||||
Cabal-Version: >= 1.6
|
|
||||||
Build-Type: Simple
|
|
||||||
|
|
||||||
Extra-source-files:
|
|
||||||
test/Test.hs
|
|
||||||
test/UserData.hs
|
|
||||||
|
|
||||||
Library
|
|
||||||
Build-depends: base >=4 && <5,
|
|
||||||
mtl >= 2.0 && < 2.1,
|
|
||||||
bytestring >= 0.9 && < 0.10,
|
|
||||||
text >= 0.11 && < 0.12,
|
|
||||||
vector >= 0.7 && < 0.10,
|
|
||||||
attoparsec >= 0.8 && < 0.10,
|
|
||||||
binary >= 0.5.0 && < 0.5.1,
|
|
||||||
data-binary-ieee754 >= 0.4 && < 0.5,
|
|
||||||
deepseq >= 1.1 && <1.3,
|
|
||||||
template-haskell >= 2.4 && < 2.7
|
|
||||||
|
|
||||||
Ghc-options: -Wall
|
|
||||||
Hs-source-dirs: src
|
|
||||||
|
|
||||||
Exposed-modules:
|
|
||||||
Data.MessagePack
|
|
||||||
Data.MessagePack.Assoc
|
|
||||||
Data.MessagePack.Pack
|
|
||||||
Data.MessagePack.Unpack
|
|
||||||
Data.MessagePack.Object
|
|
||||||
Data.MessagePack.Derive
|
|
||||||
|
|
||||||
Other-modules:
|
|
||||||
Data.MessagePack.Internal.Utf8
|
|
||||||
|
|
||||||
Source-repository head
|
|
||||||
Type: git
|
|
||||||
Location: git://github.com/msgpack/msgpack.git
|
|
||||||
@ -1,27 +0,0 @@
|
|||||||
--------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Data.MessagePack
|
|
||||||
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
|
||||||
-- Stability : experimental
|
|
||||||
-- Portability: portable
|
|
||||||
--
|
|
||||||
-- Simple interface to pack and unpack MessagePack data.
|
|
||||||
--
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
|
|
||||||
module Data.MessagePack(
|
|
||||||
module Data.MessagePack.Assoc,
|
|
||||||
module Data.MessagePack.Pack,
|
|
||||||
module Data.MessagePack.Unpack,
|
|
||||||
module Data.MessagePack.Object,
|
|
||||||
module Data.MessagePack.Derive,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.MessagePack.Assoc
|
|
||||||
import Data.MessagePack.Pack
|
|
||||||
import Data.MessagePack.Unpack
|
|
||||||
import Data.MessagePack.Object
|
|
||||||
import Data.MessagePack.Derive
|
|
||||||
@ -1,28 +0,0 @@
|
|||||||
{-# Language DeriveDataTypeable #-}
|
|
||||||
{-# Language GeneralizedNewtypeDeriving #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Data.MessagePack.Assoc
|
|
||||||
-- Copyright : (c) Daiki Handa, 2010
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
|
||||||
-- Stability : experimental
|
|
||||||
-- Portability: portable
|
|
||||||
--
|
|
||||||
-- MessagePack map labeling type
|
|
||||||
--
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
|
|
||||||
module Data.MessagePack.Assoc (
|
|
||||||
Assoc(..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.DeepSeq
|
|
||||||
import Data.Typeable
|
|
||||||
|
|
||||||
-- not defined for general Functor for performance reason.
|
|
||||||
-- (ie. you would want to write custom instances for each type using specialized mapM-like functions)
|
|
||||||
newtype Assoc a=Assoc{unAssoc :: a} deriving(Show,Eq,Ord,Typeable,NFData)
|
|
||||||
|
|
||||||
@ -1,137 +0,0 @@
|
|||||||
{-# Language TemplateHaskell #-}
|
|
||||||
{-# Language FlexibleInstances #-}
|
|
||||||
|
|
||||||
module Data.MessagePack.Derive (
|
|
||||||
-- | deriving OBJECT
|
|
||||||
derivePack,
|
|
||||||
deriveUnpack,
|
|
||||||
deriveObject,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Error () -- MonadPlus instance for Either e
|
|
||||||
import Data.Char
|
|
||||||
import Data.List
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Language.Haskell.TH
|
|
||||||
|
|
||||||
import Data.MessagePack.Assoc
|
|
||||||
import Data.MessagePack.Pack
|
|
||||||
import Data.MessagePack.Unpack
|
|
||||||
import Data.MessagePack.Object
|
|
||||||
|
|
||||||
derivePack :: Bool -> Name -> Q [Dec]
|
|
||||||
derivePack asObject tyName = do
|
|
||||||
info <- reify tyName
|
|
||||||
d <- case info of
|
|
||||||
TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do
|
|
||||||
ds <- [d| put v = $(caseE [| v |] (map alt cons)) |]
|
|
||||||
instanceD (cx tyVars) (ct ''Packable name tyVars) $
|
|
||||||
map return ds
|
|
||||||
|
|
||||||
_ -> error $ "cant derive Packable: " ++ show tyName
|
|
||||||
return [d]
|
|
||||||
|
|
||||||
where
|
|
||||||
alt (NormalC conName elms) = do
|
|
||||||
vars <- replicateM (length elms) (newName "v")
|
|
||||||
match (conP conName $ map varP vars)
|
|
||||||
(normalB [| put $(tupE $ map varE vars) |])
|
|
||||||
[]
|
|
||||||
|
|
||||||
alt (RecC conName elms) = do
|
|
||||||
vars <- replicateM (length elms) (newName "v")
|
|
||||||
if asObject
|
|
||||||
then
|
|
||||||
match (conP conName $ map varP vars)
|
|
||||||
(normalB
|
|
||||||
[| put $ Assoc
|
|
||||||
$(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) :: T.Text
|
|
||||||
, toObject $(varE v)) |]
|
|
||||||
| (v, (fname, _, _)) <- zip vars elms])
|
|
||||||
|])
|
|
||||||
[]
|
|
||||||
else
|
|
||||||
match (conP conName $ map varP vars)
|
|
||||||
(normalB [| put $(tupE $ map varE vars) |])
|
|
||||||
[]
|
|
||||||
|
|
||||||
alt c = error $ "unsupported constructor: " ++ pprint c
|
|
||||||
|
|
||||||
deriveUnpack :: Bool -> Name -> Q [Dec]
|
|
||||||
deriveUnpack asObject tyName = do
|
|
||||||
info <- reify tyName
|
|
||||||
d <- case info of
|
|
||||||
TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do
|
|
||||||
ds <- [d| get = $(foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons) |]
|
|
||||||
instanceD (cx tyVars) (ct ''Unpackable name tyVars) $
|
|
||||||
map return ds
|
|
||||||
|
|
||||||
_ -> error $ "cant derive Unpackable: " ++ show tyName
|
|
||||||
return [d]
|
|
||||||
|
|
||||||
where
|
|
||||||
alt (NormalC conName elms) = do
|
|
||||||
vars <- replicateM (length elms) (newName "v")
|
|
||||||
doE [ bindS (tupP $ map varP vars) [| get |]
|
|
||||||
, noBindS [| return $(foldl appE (conE conName) $ map varE vars) |]
|
|
||||||
]
|
|
||||||
|
|
||||||
alt (RecC conName elms) = do
|
|
||||||
var <- newName "v"
|
|
||||||
vars <- replicateM (length elms) (newName "w")
|
|
||||||
if asObject
|
|
||||||
then
|
|
||||||
doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ]
|
|
||||||
++ zipWith (binds conName var) vars elms ++
|
|
||||||
[ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ]
|
|
||||||
else
|
|
||||||
doE [ bindS (tupP $ map varP vars) [| get |]
|
|
||||||
, noBindS [| return $(foldl appE (conE conName) $ map varE vars) |]
|
|
||||||
]
|
|
||||||
|
|
||||||
alt c = error $ "unsupported constructor: " ++ pprint c
|
|
||||||
|
|
||||||
binds conName var res (fname, _, _) =
|
|
||||||
bindS (varP res)
|
|
||||||
[| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text)
|
|
||||||
$(varE var) |]
|
|
||||||
|
|
||||||
deriveObject :: Bool -> Name -> Q [Dec]
|
|
||||||
deriveObject asObject tyName = do
|
|
||||||
g <- derivePack asObject tyName
|
|
||||||
p <- deriveUnpack asObject tyName
|
|
||||||
info <- reify tyName
|
|
||||||
o <- case info of
|
|
||||||
TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) ->
|
|
||||||
-- use default implement
|
|
||||||
instanceD (cx tyVars) (ct ''OBJECT name tyVars) []
|
|
||||||
_ -> error $ "cant derive Object: " ++ show tyName
|
|
||||||
return $ g ++ p ++ [o]
|
|
||||||
|
|
||||||
failN Nothing = mzero
|
|
||||||
failN (Just a) =
|
|
||||||
case tryFromObject a of
|
|
||||||
Left _ -> mzero
|
|
||||||
Right v -> return v
|
|
||||||
|
|
||||||
cx tyVars =
|
|
||||||
cxt [ classP cl [varT tv]
|
|
||||||
| cl <- [''Packable, ''Unpackable, ''OBJECT]
|
|
||||||
, PlainTV tv <- tyVars ]
|
|
||||||
|
|
||||||
ct tc tyName tyVars =
|
|
||||||
appT (conT tc) $ foldl appT (conT tyName) $
|
|
||||||
map (\(PlainTV n) -> varT n) tyVars
|
|
||||||
|
|
||||||
key conName fname
|
|
||||||
| (prefix ++ "_") `isPrefixOf` sFname && length sFname > length prefix + 1 =
|
|
||||||
drop (length prefix + 1) sFname
|
|
||||||
| prefix `isPrefixOf` sFname && length sFname > length prefix =
|
|
||||||
uncapital $ drop (length prefix) sFname
|
|
||||||
| otherwise = sFname
|
|
||||||
where
|
|
||||||
prefix = map toLower $ nameBase conName
|
|
||||||
sFname = nameBase fname
|
|
||||||
uncapital (c:cs) | isUpper c = toLower c : cs
|
|
||||||
uncapital cs = cs
|
|
||||||
@ -1,28 +0,0 @@
|
|||||||
module Data.MessagePack.Internal.Utf8 (
|
|
||||||
encodeUtf8,
|
|
||||||
decodeUtf8,
|
|
||||||
skipChar,
|
|
||||||
toLBS,
|
|
||||||
fromLBS,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.Encoding as T
|
|
||||||
import qualified Data.Text.Encoding.Error as T
|
|
||||||
|
|
||||||
encodeUtf8 :: String -> B.ByteString
|
|
||||||
encodeUtf8 = T.encodeUtf8 . T.pack
|
|
||||||
|
|
||||||
decodeUtf8 :: B.ByteString -> String
|
|
||||||
decodeUtf8 = T.unpack . T.decodeUtf8With skipChar
|
|
||||||
|
|
||||||
skipChar :: T.OnDecodeError
|
|
||||||
skipChar _ _ = Nothing
|
|
||||||
|
|
||||||
toLBS :: B.ByteString -> BL.ByteString
|
|
||||||
toLBS bs = BL.fromChunks [bs]
|
|
||||||
|
|
||||||
fromLBS :: BL.ByteString -> B.ByteString
|
|
||||||
fromLBS = B.concat . BL.toChunks
|
|
||||||
@ -1,333 +0,0 @@
|
|||||||
{-# Language TypeSynonymInstances #-}
|
|
||||||
{-# Language FlexibleInstances #-}
|
|
||||||
{-# Language IncoherentInstances #-}
|
|
||||||
{-# Language DeriveDataTypeable #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Data.MessagePack.Object
|
|
||||||
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
|
||||||
-- Stability : experimental
|
|
||||||
-- Portability: portable
|
|
||||||
--
|
|
||||||
-- MessagePack object definition
|
|
||||||
--
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
|
|
||||||
module Data.MessagePack.Object(
|
|
||||||
-- * MessagePack Object
|
|
||||||
Object(..),
|
|
||||||
|
|
||||||
-- * Serialization to and from Object
|
|
||||||
OBJECT(..),
|
|
||||||
-- Result,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.DeepSeq
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
|
||||||
import qualified Data.Attoparsec as A
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.Encoding as T
|
|
||||||
import qualified Data.Text.Lazy as TL
|
|
||||||
import qualified Data.Text.Lazy.Encoding as TL
|
|
||||||
import Data.Typeable
|
|
||||||
|
|
||||||
import Data.MessagePack.Assoc
|
|
||||||
import Data.MessagePack.Pack
|
|
||||||
import Data.MessagePack.Unpack
|
|
||||||
import Data.MessagePack.Internal.Utf8
|
|
||||||
|
|
||||||
-- | Object Representation of MessagePack data.
|
|
||||||
data Object
|
|
||||||
= ObjectNil
|
|
||||||
| ObjectBool Bool
|
|
||||||
| ObjectInteger Int
|
|
||||||
| ObjectFloat Float
|
|
||||||
| ObjectDouble Double
|
|
||||||
| ObjectRAW B.ByteString
|
|
||||||
| ObjectArray [Object]
|
|
||||||
| ObjectMap [(Object, Object)]
|
|
||||||
deriving (Show, Eq, Ord, Typeable)
|
|
||||||
|
|
||||||
|
|
||||||
instance NFData Object where
|
|
||||||
rnf obj =
|
|
||||||
case obj of
|
|
||||||
ObjectNil -> ()
|
|
||||||
ObjectBool b -> rnf b
|
|
||||||
ObjectInteger n -> rnf n
|
|
||||||
ObjectFloat f -> rnf f
|
|
||||||
ObjectDouble d -> rnf d
|
|
||||||
ObjectRAW bs -> bs `seq` ()
|
|
||||||
ObjectArray a -> rnf a
|
|
||||||
ObjectMap m -> rnf m
|
|
||||||
|
|
||||||
|
|
||||||
instance Unpackable Object where
|
|
||||||
get =
|
|
||||||
A.choice
|
|
||||||
[ liftM ObjectInteger get
|
|
||||||
, liftM (\() -> ObjectNil) get
|
|
||||||
, liftM ObjectBool get
|
|
||||||
, liftM ObjectFloat get
|
|
||||||
, liftM ObjectDouble get
|
|
||||||
, liftM ObjectRAW get
|
|
||||||
, liftM ObjectArray get
|
|
||||||
, liftM (ObjectMap . unAssoc) get
|
|
||||||
]
|
|
||||||
|
|
||||||
instance Packable Object where
|
|
||||||
put obj =
|
|
||||||
case obj of
|
|
||||||
ObjectInteger n ->
|
|
||||||
put n
|
|
||||||
ObjectNil ->
|
|
||||||
put ()
|
|
||||||
ObjectBool b ->
|
|
||||||
put b
|
|
||||||
ObjectFloat f ->
|
|
||||||
put f
|
|
||||||
ObjectDouble d ->
|
|
||||||
put d
|
|
||||||
ObjectRAW raw ->
|
|
||||||
put raw
|
|
||||||
ObjectArray arr ->
|
|
||||||
put arr
|
|
||||||
ObjectMap m ->
|
|
||||||
put $ Assoc m
|
|
||||||
|
|
||||||
-- | The class of types serializable to and from MessagePack object
|
|
||||||
class (Unpackable a, Packable a) => OBJECT a where
|
|
||||||
-- | Encode a value to MessagePack object
|
|
||||||
toObject :: a -> Object
|
|
||||||
toObject = unpack . pack
|
|
||||||
|
|
||||||
-- | Decode a value from MessagePack object
|
|
||||||
fromObject :: Object -> a
|
|
||||||
fromObject a =
|
|
||||||
case tryFromObject a of
|
|
||||||
Left err ->
|
|
||||||
throw $ UnpackError err
|
|
||||||
Right ret ->
|
|
||||||
ret
|
|
||||||
|
|
||||||
-- | Decode a value from MessagePack object
|
|
||||||
tryFromObject :: Object -> Either String a
|
|
||||||
tryFromObject = tryUnpack . pack
|
|
||||||
|
|
||||||
instance OBJECT Object where
|
|
||||||
toObject = id
|
|
||||||
tryFromObject = Right
|
|
||||||
|
|
||||||
tryFromObjectError :: Either String a
|
|
||||||
tryFromObjectError = Left "tryFromObject: cannot cast"
|
|
||||||
|
|
||||||
instance OBJECT () where
|
|
||||||
toObject = const ObjectNil
|
|
||||||
tryFromObject ObjectNil = Right ()
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT Int where
|
|
||||||
toObject = ObjectInteger
|
|
||||||
tryFromObject (ObjectInteger n) = Right n
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT Bool where
|
|
||||||
toObject = ObjectBool
|
|
||||||
tryFromObject (ObjectBool b) = Right b
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT Double where
|
|
||||||
toObject = ObjectDouble
|
|
||||||
tryFromObject (ObjectDouble d) = Right d
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT Float where
|
|
||||||
toObject = ObjectFloat
|
|
||||||
tryFromObject (ObjectFloat f) = Right f
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT String where
|
|
||||||
toObject = toObject . encodeUtf8
|
|
||||||
tryFromObject obj = liftM decodeUtf8 $ tryFromObject obj
|
|
||||||
|
|
||||||
instance OBJECT B.ByteString where
|
|
||||||
toObject = ObjectRAW
|
|
||||||
tryFromObject (ObjectRAW bs) = Right bs
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT BL.ByteString where
|
|
||||||
toObject = ObjectRAW . fromLBS
|
|
||||||
tryFromObject (ObjectRAW bs) = Right $ toLBS bs
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT T.Text where
|
|
||||||
toObject = ObjectRAW . T.encodeUtf8
|
|
||||||
tryFromObject (ObjectRAW bs) = Right $ T.decodeUtf8With skipChar bs
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT TL.Text where
|
|
||||||
toObject = ObjectRAW . fromLBS . TL.encodeUtf8
|
|
||||||
tryFromObject (ObjectRAW bs) = Right $ TL.decodeUtf8With skipChar $ toLBS bs
|
|
||||||
tryFromObject _ = tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT a => OBJECT [a] where
|
|
||||||
toObject = ObjectArray . map toObject
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
mapM tryFromObject arr
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2) => OBJECT (a1, a2) where
|
|
||||||
toObject (a1, a2) = ObjectArray [toObject a1, toObject a2]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
return (v1, v2)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2, OBJECT a3) => OBJECT (a1, a2, a3) where
|
|
||||||
toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2, o3] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
v3 <- tryFromObject o3
|
|
||||||
return (v1, v2, v3)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4) => OBJECT (a1, a2, a3, a4) where
|
|
||||||
toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2, o3, o4] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
v3 <- tryFromObject o3
|
|
||||||
v4 <- tryFromObject o4
|
|
||||||
return (v1, v2, v3, v4)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5) => OBJECT (a1, a2, a3, a4, a5) where
|
|
||||||
toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2, o3, o4, o5] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
v3 <- tryFromObject o3
|
|
||||||
v4 <- tryFromObject o4
|
|
||||||
v5 <- tryFromObject o5
|
|
||||||
return (v1, v2, v3, v4, v5)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6) => OBJECT (a1, a2, a3, a4, a5, a6) where
|
|
||||||
toObject (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2, o3, o4, o5, o6] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
v3 <- tryFromObject o3
|
|
||||||
v4 <- tryFromObject o4
|
|
||||||
v5 <- tryFromObject o5
|
|
||||||
v6 <- tryFromObject o6
|
|
||||||
return (v1, v2, v3, v4, v5, v6)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7) => OBJECT (a1, a2, a3, a4, a5, a6, a7) where
|
|
||||||
toObject (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2, o3, o4, o5, o6, o7] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
v3 <- tryFromObject o3
|
|
||||||
v4 <- tryFromObject o4
|
|
||||||
v5 <- tryFromObject o5
|
|
||||||
v6 <- tryFromObject o6
|
|
||||||
v7 <- tryFromObject o7
|
|
||||||
return (v1, v2, v3, v4, v5, v6, v7)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7, OBJECT a8) => OBJECT (a1, a2, a3, a4, a5, a6, a7, a8) where
|
|
||||||
toObject (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2, o3, o4, o5, o6, o7, o8] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
v3 <- tryFromObject o3
|
|
||||||
v4 <- tryFromObject o4
|
|
||||||
v5 <- tryFromObject o5
|
|
||||||
v6 <- tryFromObject o6
|
|
||||||
v7 <- tryFromObject o7
|
|
||||||
v8 <- tryFromObject o8
|
|
||||||
return (v1, v2, v3, v4, v5, v6, v7, v8)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7, OBJECT a8, OBJECT a9) => OBJECT (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
|
|
||||||
toObject (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8, toObject a9]
|
|
||||||
tryFromObject (ObjectArray arr) =
|
|
||||||
case arr of
|
|
||||||
[o1, o2, o3, o4, o5, o6, o7, o8, o9] -> do
|
|
||||||
v1 <- tryFromObject o1
|
|
||||||
v2 <- tryFromObject o2
|
|
||||||
v3 <- tryFromObject o3
|
|
||||||
v4 <- tryFromObject o4
|
|
||||||
v5 <- tryFromObject o5
|
|
||||||
v6 <- tryFromObject o6
|
|
||||||
v7 <- tryFromObject o7
|
|
||||||
v8 <- tryFromObject o8
|
|
||||||
v9 <- tryFromObject o9
|
|
||||||
return (v1, v2, v3, v4, v5, v6, v7, v8, v9)
|
|
||||||
_ ->
|
|
||||||
tryFromObjectError
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance (OBJECT a, OBJECT b) => OBJECT (Assoc [(a,b)]) where
|
|
||||||
toObject =
|
|
||||||
ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . unAssoc
|
|
||||||
tryFromObject (ObjectMap mem) = do
|
|
||||||
liftM Assoc $ mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem
|
|
||||||
tryFromObject _ =
|
|
||||||
tryFromObjectError
|
|
||||||
|
|
||||||
instance OBJECT a => OBJECT (Maybe a) where
|
|
||||||
toObject (Just a) = toObject a
|
|
||||||
toObject Nothing = ObjectNil
|
|
||||||
|
|
||||||
tryFromObject ObjectNil = return Nothing
|
|
||||||
tryFromObject obj = liftM Just $ tryFromObject obj
|
|
||||||
|
|
||||||
@ -1,204 +0,0 @@
|
|||||||
{-# Language FlexibleInstances #-}
|
|
||||||
{-# Language IncoherentInstances #-}
|
|
||||||
{-# Language TypeSynonymInstances #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Data.MessagePack.Pack
|
|
||||||
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
|
||||||
-- Stability : experimental
|
|
||||||
-- Portability: portable
|
|
||||||
--
|
|
||||||
-- MessagePack Serializer using @Data.Binary.Pack@
|
|
||||||
--
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
|
|
||||||
module Data.MessagePack.Pack (
|
|
||||||
-- * Serializable class
|
|
||||||
Packable(..),
|
|
||||||
-- * Simple function to pack a Haskell value
|
|
||||||
pack,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Binary.Put
|
|
||||||
import Data.Binary.IEEE754
|
|
||||||
import Data.Bits
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.Encoding as T
|
|
||||||
import qualified Data.Text.Lazy as TL
|
|
||||||
import qualified Data.Text.Lazy.Encoding as TL
|
|
||||||
import qualified Data.Vector as V
|
|
||||||
|
|
||||||
import Data.MessagePack.Assoc
|
|
||||||
import Data.MessagePack.Internal.Utf8
|
|
||||||
|
|
||||||
-- | Serializable class
|
|
||||||
class Packable a where
|
|
||||||
-- | Serialize a value
|
|
||||||
put :: a -> Put
|
|
||||||
|
|
||||||
-- | Pack Haskell data to MessagePack string.
|
|
||||||
pack :: Packable a => a -> BL.ByteString
|
|
||||||
pack = runPut . put
|
|
||||||
|
|
||||||
instance Packable Int where
|
|
||||||
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 Packable () where
|
|
||||||
put _ =
|
|
||||||
putWord8 0xC0
|
|
||||||
|
|
||||||
instance Packable Bool where
|
|
||||||
put True = putWord8 0xC3
|
|
||||||
put False = putWord8 0xC2
|
|
||||||
|
|
||||||
instance Packable Float where
|
|
||||||
put f = do
|
|
||||||
putWord8 0xCA
|
|
||||||
putFloat32be f
|
|
||||||
|
|
||||||
instance Packable Double where
|
|
||||||
put d = do
|
|
||||||
putWord8 0xCB
|
|
||||||
putFloat64be d
|
|
||||||
|
|
||||||
instance Packable String where
|
|
||||||
put = putString encodeUtf8 B.length putByteString
|
|
||||||
|
|
||||||
instance Packable B.ByteString where
|
|
||||||
put = putString id B.length putByteString
|
|
||||||
|
|
||||||
instance Packable BL.ByteString where
|
|
||||||
put = putString id (fromIntegral . BL.length) putLazyByteString
|
|
||||||
|
|
||||||
instance Packable T.Text where
|
|
||||||
put = putString T.encodeUtf8 B.length putByteString
|
|
||||||
|
|
||||||
instance Packable TL.Text where
|
|
||||||
put = putString TL.encodeUtf8 (fromIntegral . BL.length) putLazyByteString
|
|
||||||
|
|
||||||
putString :: (s -> t) -> (t -> Int) -> (t -> Put) -> s -> Put
|
|
||||||
putString cnv lf pf str = do
|
|
||||||
let bs = cnv str
|
|
||||||
case lf bs of
|
|
||||||
len | len <= 31 -> do
|
|
||||||
putWord8 $ 0xA0 .|. fromIntegral len
|
|
||||||
len | len < 0x10000 -> do
|
|
||||||
putWord8 0xDA
|
|
||||||
putWord16be $ fromIntegral len
|
|
||||||
len -> do
|
|
||||||
putWord8 0xDB
|
|
||||||
putWord32be $ fromIntegral len
|
|
||||||
pf bs
|
|
||||||
|
|
||||||
instance Packable a => Packable [a] where
|
|
||||||
put = putArray length (mapM_ put)
|
|
||||||
|
|
||||||
instance Packable a => Packable (V.Vector a) where
|
|
||||||
put = putArray V.length (V.mapM_ put)
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2) => Packable (a1, a2) where
|
|
||||||
put = putArray (const 2) f where
|
|
||||||
f (a1, a2) = put a1 >> put a2
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where
|
|
||||||
put = putArray (const 3) f where
|
|
||||||
f (a1, a2, a3) = put a1 >> put a2 >> put a3
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (a1, a2, a3, a4) where
|
|
||||||
put = putArray (const 4) f where
|
|
||||||
f (a1, a2, a3, a4) = put a1 >> put a2 >> put a3 >> put a4
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (a1, a2, a3, a4, a5) where
|
|
||||||
put = putArray (const 5) f where
|
|
||||||
f (a1, a2, a3, a4, a5) = put a1 >> put a2 >> put a3 >> put a4 >> put a5
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (a1, a2, a3, a4, a5, a6) where
|
|
||||||
put = putArray (const 6) f where
|
|
||||||
f (a1, a2, a3, a4, a5, a6) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7) => Packable (a1, a2, a3, a4, a5, a6, a7) where
|
|
||||||
put = putArray (const 7) f where
|
|
||||||
f (a1, a2, a3, a4, a5, a6, a7) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8) => Packable (a1, a2, a3, a4, a5, a6, a7, a8) where
|
|
||||||
put = putArray (const 8) f where
|
|
||||||
f (a1, a2, a3, a4, a5, a6, a7, a8) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8
|
|
||||||
|
|
||||||
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8, Packable a9) => Packable (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
|
|
||||||
put = putArray (const 9) f where
|
|
||||||
f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8 >> put a9
|
|
||||||
|
|
||||||
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 (Packable k, Packable v) => Packable (Assoc [(k,v)]) where
|
|
||||||
put = putMap length (mapM_ putPair) . unAssoc
|
|
||||||
|
|
||||||
instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where
|
|
||||||
put = putMap V.length (V.mapM_ putPair) . unAssoc
|
|
||||||
|
|
||||||
putPair :: (Packable a, Packable b) => (a, b) -> Put
|
|
||||||
putPair (a, b) = put a >> put b
|
|
||||||
|
|
||||||
putMap :: (a -> Int) -> (a -> Put) -> a -> Put
|
|
||||||
putMap lf pf m = do
|
|
||||||
case lf m of
|
|
||||||
len | len <= 15 ->
|
|
||||||
putWord8 $ 0x80 .|. fromIntegral len
|
|
||||||
len | len < 0x10000 -> do
|
|
||||||
putWord8 0xDE
|
|
||||||
putWord16be $ fromIntegral len
|
|
||||||
len -> do
|
|
||||||
putWord8 0xDF
|
|
||||||
putWord32be $ fromIntegral len
|
|
||||||
pf m
|
|
||||||
|
|
||||||
instance Packable a => Packable (Maybe a) where
|
|
||||||
put Nothing = put ()
|
|
||||||
put (Just a) = put a
|
|
||||||
|
|
||||||
@ -1,323 +0,0 @@
|
|||||||
{-# Language FlexibleInstances #-}
|
|
||||||
{-# Language IncoherentInstances #-}
|
|
||||||
{-# Language TypeSynonymInstances #-}
|
|
||||||
{-# Language DeriveDataTypeable #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Data.MessagePack.Unpack
|
|
||||||
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
|
||||||
-- Stability : experimental
|
|
||||||
-- Portability: portable
|
|
||||||
--
|
|
||||||
-- MessagePack Deserializer using @Data.Attoparsec@
|
|
||||||
--
|
|
||||||
--------------------------------------------------------------------
|
|
||||||
|
|
||||||
module Data.MessagePack.Unpack(
|
|
||||||
-- * MessagePack deserializer
|
|
||||||
Unpackable(..),
|
|
||||||
-- * Simple function to unpack a Haskell value
|
|
||||||
unpack,
|
|
||||||
tryUnpack,
|
|
||||||
-- * Unpack exception
|
|
||||||
UnpackError(..),
|
|
||||||
-- * ByteString utils
|
|
||||||
IsByteString(..),
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
|
||||||
import qualified Data.Attoparsec as A
|
|
||||||
import Data.Binary.Get
|
|
||||||
import Data.Binary.IEEE754
|
|
||||||
import Data.Bits
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.Encoding as T
|
|
||||||
import qualified Data.Text.Lazy as TL
|
|
||||||
import qualified Data.Text.Lazy.Encoding as TL
|
|
||||||
import Data.Int
|
|
||||||
import Data.Typeable
|
|
||||||
import qualified Data.Vector as V
|
|
||||||
import Data.Word
|
|
||||||
import Text.Printf
|
|
||||||
|
|
||||||
import Data.MessagePack.Assoc
|
|
||||||
import Data.MessagePack.Internal.Utf8
|
|
||||||
|
|
||||||
-- | Deserializable class
|
|
||||||
class Unpackable a where
|
|
||||||
-- | Deserialize a value
|
|
||||||
get :: A.Parser a
|
|
||||||
|
|
||||||
class IsByteString s where
|
|
||||||
toBS :: s -> B.ByteString
|
|
||||||
|
|
||||||
instance IsByteString B.ByteString where
|
|
||||||
toBS = id
|
|
||||||
|
|
||||||
instance IsByteString BL.ByteString where
|
|
||||||
toBS = B.concat . BL.toChunks
|
|
||||||
|
|
||||||
-- | The exception of unpack
|
|
||||||
data UnpackError =
|
|
||||||
UnpackError String
|
|
||||||
deriving (Show, Typeable)
|
|
||||||
|
|
||||||
instance Exception UnpackError
|
|
||||||
|
|
||||||
-- | Unpack MessagePack string to Haskell data.
|
|
||||||
unpack :: (Unpackable a, IsByteString s) => s -> a
|
|
||||||
unpack bs =
|
|
||||||
case tryUnpack bs of
|
|
||||||
Left err ->
|
|
||||||
throw $ UnpackError err
|
|
||||||
Right ret ->
|
|
||||||
ret
|
|
||||||
|
|
||||||
-- | Unpack MessagePack string to Haskell data.
|
|
||||||
tryUnpack :: (Unpackable a, IsByteString s) => s -> Either String a
|
|
||||||
tryUnpack bs =
|
|
||||||
case A.parse get (toBS bs) of
|
|
||||||
A.Fail _ _ err ->
|
|
||||||
Left err
|
|
||||||
A.Partial _ ->
|
|
||||||
Left "not enough input"
|
|
||||||
A.Done _ ret ->
|
|
||||||
Right ret
|
|
||||||
|
|
||||||
instance Unpackable Int where
|
|
||||||
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 Unpackable () where
|
|
||||||
get = do
|
|
||||||
c <- A.anyWord8
|
|
||||||
case c of
|
|
||||||
0xC0 ->
|
|
||||||
return ()
|
|
||||||
_ ->
|
|
||||||
fail $ printf "invlid nil tag: 0x%02X" c
|
|
||||||
|
|
||||||
instance Unpackable Bool where
|
|
||||||
get = do
|
|
||||||
c <- A.anyWord8
|
|
||||||
case c of
|
|
||||||
0xC3 ->
|
|
||||||
return True
|
|
||||||
0xC2 ->
|
|
||||||
return False
|
|
||||||
_ ->
|
|
||||||
fail $ printf "invlid bool tag: 0x%02X" c
|
|
||||||
|
|
||||||
instance Unpackable Float where
|
|
||||||
get = do
|
|
||||||
c <- A.anyWord8
|
|
||||||
case c of
|
|
||||||
0xCA ->
|
|
||||||
return . runGet getFloat32be . toLBS =<< A.take 4
|
|
||||||
_ ->
|
|
||||||
fail $ printf "invlid float tag: 0x%02X" c
|
|
||||||
|
|
||||||
instance Unpackable Double where
|
|
||||||
get = do
|
|
||||||
c <- A.anyWord8
|
|
||||||
case c of
|
|
||||||
0xCB ->
|
|
||||||
return . runGet getFloat64be . toLBS =<< A.take 8
|
|
||||||
_ ->
|
|
||||||
fail $ printf "invlid double tag: 0x%02X" c
|
|
||||||
|
|
||||||
instance Unpackable String where
|
|
||||||
get = parseString (\n -> return . decodeUtf8 =<< A.take n)
|
|
||||||
|
|
||||||
instance Unpackable B.ByteString where
|
|
||||||
get = parseString A.take
|
|
||||||
|
|
||||||
instance Unpackable BL.ByteString where
|
|
||||||
get = parseString (\n -> return . toLBS =<< A.take n)
|
|
||||||
|
|
||||||
instance Unpackable T.Text where
|
|
||||||
get = parseString (\n -> return . T.decodeUtf8With skipChar =<< A.take n)
|
|
||||||
|
|
||||||
instance Unpackable TL.Text where
|
|
||||||
get = parseString (\n -> return . TL.decodeUtf8With skipChar . toLBS =<< A.take n)
|
|
||||||
|
|
||||||
parseString :: (Int -> A.Parser a) -> A.Parser a
|
|
||||||
parseString aget = do
|
|
||||||
c <- A.anyWord8
|
|
||||||
case c of
|
|
||||||
_ | c .&. 0xE0 == 0xA0 ->
|
|
||||||
aget . fromIntegral $ c .&. 0x1F
|
|
||||||
0xDA ->
|
|
||||||
aget . fromIntegral =<< parseUint16
|
|
||||||
0xDB ->
|
|
||||||
aget . fromIntegral =<< parseUint32
|
|
||||||
_ ->
|
|
||||||
fail $ printf "invlid raw tag: 0x%02X" c
|
|
||||||
|
|
||||||
instance Unpackable a => Unpackable [a] where
|
|
||||||
get = parseArray (flip replicateM get)
|
|
||||||
|
|
||||||
instance Unpackable a => Unpackable (V.Vector a) where
|
|
||||||
get = parseArray (flip V.replicateM get)
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2) => Unpackable (a1, a2) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 2 = get >>= \a1 -> get >>= \a2 -> return (a1, a2)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 2 but got %d" n
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2, Unpackable a3) => Unpackable (a1, a2, a3) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 3 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> return (a1, a2, a3)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 3 but got %d" n
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4) => Unpackable (a1, a2, a3, a4) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 4 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> return (a1, a2, a3, a4)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 4 but got %d" n
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5) => Unpackable (a1, a2, a3, a4, a5) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 5 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> return (a1, a2, a3, a4, a5)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 5 but got %d" n
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6) => Unpackable (a1, a2, a3, a4, a5, a6) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 6 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> return (a1, a2, a3, a4, a5, a6)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 6 but got %d" n
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7) => Unpackable (a1, a2, a3, a4, a5, a6, a7) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 7 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> return (a1, a2, a3, a4, a5, a6, a7)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 7 but got %d" n
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7, Unpackable a8) => Unpackable (a1, a2, a3, a4, a5, a6, a7, a8) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 8 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> return (a1, a2, a3, a4, a5, a6, a7, a8)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 8 but got %d" n
|
|
||||||
|
|
||||||
instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7, Unpackable a8, Unpackable a9) => Unpackable (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
|
|
||||||
get = parseArray f where
|
|
||||||
f 9 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> get >>= \a9 -> return (a1, a2, a3, a4, a5, a6, a7, a8, a9)
|
|
||||||
f n = fail $ printf "wrong tupple size: expected 9 but got %d" n
|
|
||||||
|
|
||||||
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 (Unpackable k, Unpackable v) => Unpackable (Assoc [(k,v)]) where
|
|
||||||
get = liftM Assoc $ parseMap (flip replicateM parsePair)
|
|
||||||
|
|
||||||
instance (Unpackable k, Unpackable v) => Unpackable (Assoc (V.Vector (k, v))) where
|
|
||||||
get = liftM Assoc $ parseMap (flip V.replicateM parsePair)
|
|
||||||
|
|
||||||
parsePair :: (Unpackable k, Unpackable v) => A.Parser (k, v)
|
|
||||||
parsePair = do
|
|
||||||
a <- get
|
|
||||||
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
|
|
||||||
|
|
||||||
instance Unpackable a => Unpackable (Maybe a) where
|
|
||||||
get =
|
|
||||||
A.choice
|
|
||||||
[ liftM Just get
|
|
||||||
, liftM (\() -> Nothing) get ]
|
|
||||||
|
|
||||||
parseUint16 :: A.Parser Word16
|
|
||||||
parseUint16 = do
|
|
||||||
b0 <- A.anyWord8
|
|
||||||
b1 <- A.anyWord8
|
|
||||||
return $ (fromIntegral b0 `shiftL` 8) .|. fromIntegral b1
|
|
||||||
|
|
||||||
parseUint32 :: A.Parser Word32
|
|
||||||
parseUint32 = do
|
|
||||||
b0 <- A.anyWord8
|
|
||||||
b1 <- A.anyWord8
|
|
||||||
b2 <- A.anyWord8
|
|
||||||
b3 <- A.anyWord8
|
|
||||||
return $ (fromIntegral b0 `shiftL` 24) .|.
|
|
||||||
(fromIntegral b1 `shiftL` 16) .|.
|
|
||||||
(fromIntegral b2 `shiftL` 8) .|.
|
|
||||||
fromIntegral b3
|
|
||||||
|
|
||||||
parseUint64 :: A.Parser Word64
|
|
||||||
parseUint64 = do
|
|
||||||
b0 <- A.anyWord8
|
|
||||||
b1 <- A.anyWord8
|
|
||||||
b2 <- A.anyWord8
|
|
||||||
b3 <- A.anyWord8
|
|
||||||
b4 <- A.anyWord8
|
|
||||||
b5 <- A.anyWord8
|
|
||||||
b6 <- A.anyWord8
|
|
||||||
b7 <- A.anyWord8
|
|
||||||
return $ (fromIntegral b0 `shiftL` 56) .|.
|
|
||||||
(fromIntegral b1 `shiftL` 48) .|.
|
|
||||||
(fromIntegral b2 `shiftL` 40) .|.
|
|
||||||
(fromIntegral b3 `shiftL` 32) .|.
|
|
||||||
(fromIntegral b4 `shiftL` 24) .|.
|
|
||||||
(fromIntegral b5 `shiftL` 16) .|.
|
|
||||||
(fromIntegral b6 `shiftL` 8) .|.
|
|
||||||
fromIntegral b7
|
|
||||||
|
|
||||||
parseInt8 :: A.Parser Int8
|
|
||||||
parseInt8 = return . fromIntegral =<< A.anyWord8
|
|
||||||
|
|
||||||
parseInt16 :: A.Parser Int16
|
|
||||||
parseInt16 = return . fromIntegral =<< parseUint16
|
|
||||||
|
|
||||||
parseInt32 :: A.Parser Int32
|
|
||||||
parseInt32 = return . fromIntegral =<< parseUint32
|
|
||||||
|
|
||||||
parseInt64 :: A.Parser Int64
|
|
||||||
parseInt64 = return . fromIntegral =<< parseUint64
|
|
||||||
@ -1,21 +0,0 @@
|
|||||||
{-# Language OverloadedStrings #-}
|
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import Data.MessagePack
|
|
||||||
|
|
||||||
main = do
|
|
||||||
sb <- return $ packToString $ do
|
|
||||||
put [1,2,3::Int]
|
|
||||||
put (3.14 :: Double)
|
|
||||||
put ("Hoge" :: B.ByteString)
|
|
||||||
|
|
||||||
print sb
|
|
||||||
|
|
||||||
r <- unpackFromString sb $ do
|
|
||||||
arr <- get
|
|
||||||
dbl <- get
|
|
||||||
str <- get
|
|
||||||
return (arr :: [Int], dbl :: Double, str :: B.ByteString)
|
|
||||||
|
|
||||||
print r
|
|
||||||
@ -1,70 +0,0 @@
|
|||||||
import Test.Framework
|
|
||||||
import Test.Framework.Providers.QuickCheck2
|
|
||||||
import Test.QuickCheck
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
import qualified Data.ByteString.Char8 as B
|
|
||||||
import qualified Data.ByteString.Lazy.Char8 as L
|
|
||||||
import Data.MessagePack
|
|
||||||
|
|
||||||
instance Arbitrary a => Arbitrary (Assoc a) where
|
|
||||||
arbitrary = liftM Assoc arbitrary
|
|
||||||
|
|
||||||
mid :: (Packable a, Unpackable a) => a -> a
|
|
||||||
mid = unpack . pack
|
|
||||||
|
|
||||||
prop_mid_int a = a == mid a
|
|
||||||
where types = a :: Int
|
|
||||||
prop_mid_nil a = a == mid a
|
|
||||||
where types = a :: ()
|
|
||||||
prop_mid_bool a = a == mid a
|
|
||||||
where types = a :: Bool
|
|
||||||
prop_mid_double a = a == mid a
|
|
||||||
where types = a :: Double
|
|
||||||
prop_mid_string a = a == mid a
|
|
||||||
where types = a :: String
|
|
||||||
prop_mid_bytestring a = B.pack a == mid (B.pack a)
|
|
||||||
where types = a :: String
|
|
||||||
prop_mid_lazy_bytestring a = (L.pack a) == mid (L.pack a)
|
|
||||||
where types = a :: String
|
|
||||||
prop_mid_array_int a = a == mid a
|
|
||||||
where types = a :: [Int]
|
|
||||||
prop_mid_array_string a = a == mid a
|
|
||||||
where types = a :: [String]
|
|
||||||
prop_mid_pair2 a = a == mid a
|
|
||||||
where types = a :: (Int, Int)
|
|
||||||
prop_mid_pair3 a = a == mid a
|
|
||||||
where types = a :: (Int, Int, Int)
|
|
||||||
prop_mid_pair4 a = a == mid a
|
|
||||||
where types = a :: (Int, Int, Int, Int)
|
|
||||||
prop_mid_pair5 a = a == mid a
|
|
||||||
where types = a :: (Int, Int, Int, Int, Int)
|
|
||||||
prop_mid_list_int_double a = a == mid a
|
|
||||||
where types = a :: [(Int, Double)]
|
|
||||||
prop_mid_list_string_string a = a == mid a
|
|
||||||
where types = a :: [(String, String)]
|
|
||||||
prop_mid_map_string_int a = a == mid a
|
|
||||||
where types = a :: Assoc [(String,Int)]
|
|
||||||
|
|
||||||
tests =
|
|
||||||
[ testGroup "simple"
|
|
||||||
[ testProperty "int" prop_mid_int
|
|
||||||
, testProperty "nil" prop_mid_nil
|
|
||||||
, testProperty "bool" prop_mid_bool
|
|
||||||
, testProperty "double" prop_mid_double
|
|
||||||
, testProperty "string" prop_mid_string
|
|
||||||
, testProperty "bytestring" prop_mid_bytestring
|
|
||||||
, testProperty "lazy-bytestring" prop_mid_lazy_bytestring
|
|
||||||
, testProperty "[int]" prop_mid_array_int
|
|
||||||
, testProperty "[string]" prop_mid_array_string
|
|
||||||
, testProperty "(int, int)" prop_mid_pair2
|
|
||||||
, testProperty "(int, int, int)" prop_mid_pair3
|
|
||||||
, testProperty "(int, int, int, int)" prop_mid_pair4
|
|
||||||
, testProperty "(int, int, int, int, int)" prop_mid_pair5
|
|
||||||
, testProperty "[(int, double)]" prop_mid_list_int_double
|
|
||||||
, testProperty "[(string, string)]" prop_mid_list_string_string
|
|
||||||
, testProperty "Assoc [(string, int)]" prop_mid_map_string_int
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
main = defaultMain tests
|
|
||||||
@ -1,53 +0,0 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
import Data.MessagePack
|
|
||||||
|
|
||||||
data T
|
|
||||||
= A Int String
|
|
||||||
| B Double
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
deriveObject True ''T
|
|
||||||
|
|
||||||
data U
|
|
||||||
= C { c1 :: Int, c2 :: String }
|
|
||||||
| D { z1 :: Double }
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
deriveObject True ''U
|
|
||||||
|
|
||||||
data V
|
|
||||||
= E String | F
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
deriveObject True ''V
|
|
||||||
|
|
||||||
data W a
|
|
||||||
= G a String
|
|
||||||
| H { hHoge :: Int, h_age :: a }
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
deriveObject True ''W
|
|
||||||
|
|
||||||
test :: (OBJECT a, Show a, Eq a) => a -> IO ()
|
|
||||||
test v = do
|
|
||||||
let bs = pack v
|
|
||||||
print bs
|
|
||||||
print (unpack bs == v)
|
|
||||||
|
|
||||||
let oa = toObject v
|
|
||||||
print oa
|
|
||||||
print (fromObject oa == v)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
test $ A 123 "hoge"
|
|
||||||
test $ B 3.14
|
|
||||||
test $ C 123 "hoge"
|
|
||||||
test $ D 3.14
|
|
||||||
test $ E "hello"
|
|
||||||
test $ F
|
|
||||||
test $ G (E "hello") "world"
|
|
||||||
test $ H 123 F
|
|
||||||
return ()
|
|
||||||
Loading…
x
Reference in New Issue
Block a user