From b2839ac78bfdf48024e73ec8d7de6dff857ce59c Mon Sep 17 00:00:00 2001 From: FURUHASHI Sadayuki Date: Tue, 3 Jul 2012 19:14:45 -0700 Subject: [PATCH] MessagePack for Haskell moved to https://github.com/msgpack/msgpack-haskell --- haskell/LICENSE | 24 -- haskell/README | 1 + haskell/Setup.lhs | 3 - haskell/msgpack.cabal | 50 --- haskell/src/Data/MessagePack.hs | 27 -- haskell/src/Data/MessagePack/Assoc.hs | 28 -- haskell/src/Data/MessagePack/Derive.hs | 137 ------- haskell/src/Data/MessagePack/Internal/Utf8.hs | 28 -- haskell/src/Data/MessagePack/Object.hs | 333 ------------------ haskell/src/Data/MessagePack/Pack.hs | 204 ----------- haskell/src/Data/MessagePack/Unpack.hs | 323 ----------------- haskell/test/Monad.hs | 21 -- haskell/test/Test.hs | 70 ---- haskell/test/UserData.hs | 53 --- 14 files changed, 1 insertion(+), 1301 deletions(-) delete mode 100644 haskell/LICENSE delete mode 100644 haskell/Setup.lhs delete mode 100644 haskell/msgpack.cabal delete mode 100644 haskell/src/Data/MessagePack.hs delete mode 100644 haskell/src/Data/MessagePack/Assoc.hs delete mode 100644 haskell/src/Data/MessagePack/Derive.hs delete mode 100644 haskell/src/Data/MessagePack/Internal/Utf8.hs delete mode 100644 haskell/src/Data/MessagePack/Object.hs delete mode 100644 haskell/src/Data/MessagePack/Pack.hs delete mode 100644 haskell/src/Data/MessagePack/Unpack.hs delete mode 100644 haskell/test/Monad.hs delete mode 100644 haskell/test/Test.hs delete mode 100644 haskell/test/UserData.hs diff --git a/haskell/LICENSE b/haskell/LICENSE deleted file mode 100644 index 3cb4d8c8..00000000 --- a/haskell/LICENSE +++ /dev/null @@ -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 BE LIABLE FOR ANY -DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/haskell/README b/haskell/README index e69de29b..c3a919a9 100644 --- a/haskell/README +++ b/haskell/README @@ -0,0 +1 @@ +MessagePack for Haskell moved to https://github.com/msgpack/msgpack-haskell. diff --git a/haskell/Setup.lhs b/haskell/Setup.lhs deleted file mode 100644 index 5bde0de9..00000000 --- a/haskell/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal deleted file mode 100644 index a87eb833..00000000 --- a/haskell/msgpack.cabal +++ /dev/null @@ -1,50 +0,0 @@ -Name: msgpack -Version: 0.6.4 -Synopsis: A Haskell implementation of MessagePack -Description: - A Haskell implementation of MessagePack - -License: BSD3 -License-File: LICENSE -Copyright: Copyright (c) 2009-2011, Hideyuki Tanaka -Category: Data -Author: Hideyuki Tanaka -Maintainer: Hideyuki Tanaka -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 diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs deleted file mode 100644 index 801c2738..00000000 --- a/haskell/src/Data/MessagePack.hs +++ /dev/null @@ -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 diff --git a/haskell/src/Data/MessagePack/Assoc.hs b/haskell/src/Data/MessagePack/Assoc.hs deleted file mode 100644 index 525cb77f..00000000 --- a/haskell/src/Data/MessagePack/Assoc.hs +++ /dev/null @@ -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) - diff --git a/haskell/src/Data/MessagePack/Derive.hs b/haskell/src/Data/MessagePack/Derive.hs deleted file mode 100644 index 95784a80..00000000 --- a/haskell/src/Data/MessagePack/Derive.hs +++ /dev/null @@ -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 diff --git a/haskell/src/Data/MessagePack/Internal/Utf8.hs b/haskell/src/Data/MessagePack/Internal/Utf8.hs deleted file mode 100644 index c109faaa..00000000 --- a/haskell/src/Data/MessagePack/Internal/Utf8.hs +++ /dev/null @@ -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 diff --git a/haskell/src/Data/MessagePack/Object.hs b/haskell/src/Data/MessagePack/Object.hs deleted file mode 100644 index bbd27e1f..00000000 --- a/haskell/src/Data/MessagePack/Object.hs +++ /dev/null @@ -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 - diff --git a/haskell/src/Data/MessagePack/Pack.hs b/haskell/src/Data/MessagePack/Pack.hs deleted file mode 100644 index 39394ff6..00000000 --- a/haskell/src/Data/MessagePack/Pack.hs +++ /dev/null @@ -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 - diff --git a/haskell/src/Data/MessagePack/Unpack.hs b/haskell/src/Data/MessagePack/Unpack.hs deleted file mode 100644 index 557e87b4..00000000 --- a/haskell/src/Data/MessagePack/Unpack.hs +++ /dev/null @@ -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 diff --git a/haskell/test/Monad.hs b/haskell/test/Monad.hs deleted file mode 100644 index 2ec40938..00000000 --- a/haskell/test/Monad.hs +++ /dev/null @@ -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 diff --git a/haskell/test/Test.hs b/haskell/test/Test.hs deleted file mode 100644 index d3089634..00000000 --- a/haskell/test/Test.hs +++ /dev/null @@ -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 diff --git a/haskell/test/UserData.hs b/haskell/test/UserData.hs deleted file mode 100644 index 55e1d618..00000000 --- a/haskell/test/UserData.hs +++ /dev/null @@ -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 ()