generic-library/msgpack
1
0
Fork 0
mirror of https://github.com/msgpack/msgpack-c.git synced 2025-03-20 05:27:56 +01:00
Code Issues Projects Releases Wiki Activity

MessagePack for Haskell moved to https://github.com/msgpack/msgpack-haskell

Browse Source
This commit is contained in:
FURUHASHI Sadayuki 2012-07-03 19:14:45 -07:00
parent 834d5a0e72
commit b2839ac78b
14 changed files with 1 additions and 1301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
haskell/LICENSE
View File

@ -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.

1
haskell/README
View File

@ -0,0 +1 @@
MessagePack for Haskell moved to https://github.com/msgpack/msgpack-haskell.

3
haskell/Setup.lhs
View File

@ -1,3 +0,0 @@
#!/usr/bin/env runhaskell
> import Distribution.Simple
> main = defaultMain

50
haskell/msgpack.cabal
View File

@ -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

27
haskell/src/Data/MessagePack.hs
View File

@ -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

28
haskell/src/Data/MessagePack/Assoc.hs
View File

@ -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)

137
haskell/src/Data/MessagePack/Derive.hs
View File

@ -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

28
haskell/src/Data/MessagePack/Internal/Utf8.hs
View File

@ -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

333
haskell/src/Data/MessagePack/Object.hs
View File

@ -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

204
haskell/src/Data/MessagePack/Pack.hs
View File

@ -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

323
haskell/src/Data/MessagePack/Unpack.hs
View File

@ -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

21
haskell/test/Monad.hs
View File

@ -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

70
haskell/test/Test.hs
View File

@ -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

53
haskell/test/UserData.hs
View File

@ -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 ()