diff --git a/Data/MessagePack.hs b/Data/MessagePack.hs new file mode 100644 --- /dev/null +++ b/Data/MessagePack.hs @@ -0,0 +1,27 @@ +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- 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/Data/MessagePack/Assoc.hs b/Data/MessagePack/Assoc.hs new file mode 100644 --- /dev/null +++ b/Data/MessagePack/Assoc.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Assoc +-- Copyright : (c) Daiki Handa, 2010-2011 +-- 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/Data/MessagePack/Derive.hs b/Data/MessagePack/Derive.hs new file mode 100644 --- /dev/null +++ b/Data/MessagePack/Derive.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TemplateHaskell, 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| from 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 [| from $(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 + [| from $ 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 [| from $(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/Data/MessagePack/Internal/Utf8.hs b/Data/MessagePack/Internal/Utf8.hs new file mode 100644 --- /dev/null +++ b/Data/MessagePack/Internal/Utf8.hs @@ -0,0 +1,28 @@ +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/Data/MessagePack/Object.hs b/Data/MessagePack/Object.hs new file mode 100644 --- /dev/null +++ b/Data/MessagePack/Object.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Object +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- 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.Applicative +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 Data.Hashable +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import qualified Data.IntMap as IM +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.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 + from obj = + case obj of + ObjectInteger n -> + from n + ObjectNil -> + from () + ObjectBool b -> + from b + ObjectFloat f -> + from f + ObjectDouble d -> + from d + ObjectRAW raw -> + from raw + ObjectArray arr -> + from arr + ObjectMap m -> + from $ 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 + Assoc <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a, OBJECT b) => OBJECT (Assoc (V.Vector (a,b))) where + toObject = + ObjectMap . V.toList . V.map (\(a, b) -> (toObject a, toObject b)) . unAssoc + tryFromObject (ObjectMap mem) = do + Assoc <$> V.mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) (V.fromList mem) + tryFromObject _ = + tryFromObjectError + +instance (Ord a, OBJECT a, OBJECT b) => OBJECT (M.Map a b) where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . M.toList + tryFromObject (ObjectMap mem) = do + M.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem + tryFromObject _ = + tryFromObjectError + +instance OBJECT b => OBJECT (IM.IntMap b) where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . IM.toList + tryFromObject (ObjectMap mem) = do + IM.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem + tryFromObject _ = + tryFromObjectError + +instance (Hashable a, Eq a, OBJECT a, OBJECT b) => OBJECT (HM.HashMap a b) where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . HM.toList + tryFromObject (ObjectMap mem) = do + HM.fromList <$> 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/Data/MessagePack/Pack.hs b/Data/MessagePack/Pack.hs new file mode 100644 --- /dev/null +++ b/Data/MessagePack/Pack.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Pack +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- 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 Blaze.ByteString.Builder +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import qualified Data.IntMap as IM +import Data.Monoid +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 Foreign + +import Data.MessagePack.Assoc +import Data.MessagePack.Internal.Utf8 + +(<>) :: Monoid m => m -> m -> m +(<>) = mappend + +-- | Serializable class +class Packable a where + -- | Serialize a value + from :: a -> Builder + +-- | Pack Haskell data to MessagePack string. +pack :: Packable a => a -> BL.ByteString +pack = toLazyByteString . from + +instance Packable Int where + from n = + case n of + _ | n >= 0 && n <= 127 -> + fromWord8 $ fromIntegral n + _ | n >= -32 && n <= -1 -> + fromWord8 $ fromIntegral n + _ | n >= 0 && n < 0x100 -> + fromWord8 0xCC <> + fromWord8 (fromIntegral n) + _ | n >= 0 && n < 0x10000 -> + fromWord8 0xCD <> + fromWord16be (fromIntegral n) + _ | n >= 0 && n < 0x100000000 -> + fromWord8 0xCE <> + fromWord32be (fromIntegral n) + _ | n >= 0 -> + fromWord8 0xCF <> + fromWord64be (fromIntegral n) + _ | n >= -0x80 -> + fromWord8 0xD0 <> + fromWord8 (fromIntegral n) + _ | n >= -0x8000 -> + fromWord8 0xD1 <> + fromWord16be (fromIntegral n) + _ | n >= -0x80000000 -> + fromWord8 0xD2 <> + fromWord32be (fromIntegral n) + _ -> + fromWord8 0xD3 <> + fromWord64be (fromIntegral n) + +instance Packable () where + from _ = + fromWord8 0xC0 + +instance Packable Bool where + from True = fromWord8 0xC3 + from False = fromWord8 0xC2 + +instance Packable Float where + from f = + fromWord8 0xCB <> + fromWord32be (cast f) + +instance Packable Double where + from d = + fromWord8 0xCB <> + fromWord64be (cast d) + +cast :: (Storable a, Storable b) => a -> b +cast v = unsafePerformIO $ with v $ peek . castPtr + +instance Packable String where + from = fromString encodeUtf8 B.length fromByteString + +instance Packable B.ByteString where + from = fromString id B.length fromByteString + +instance Packable BL.ByteString where + from = fromString id (fromIntegral . BL.length) fromLazyByteString + +instance Packable T.Text where + from = fromString T.encodeUtf8 B.length fromByteString + +instance Packable TL.Text where + from = fromString TL.encodeUtf8 (fromIntegral . BL.length) fromLazyByteString + +fromString :: (s -> t) -> (t -> Int) -> (t -> Builder) -> s -> Builder +fromString cnv lf pf str = + let bs = cnv str in + case lf bs of + len | len <= 31 -> + fromWord8 $ 0xA0 .|. fromIntegral len + len | len < 0x10000 -> + fromWord8 0xDA <> + fromWord16be (fromIntegral len) + len -> + fromWord8 0xDB <> + fromWord32be (fromIntegral len) + <> pf bs + +instance Packable a => Packable [a] where + from = fromArray length (mconcat . map from) + +instance Packable a => Packable (V.Vector a) where + from = fromArray V.length (V.foldl (\a b -> a <> from b) mempty) + +instance (Packable a1, Packable a2) => Packable (a1, a2) where + from = fromArray (const 2) f where + f (a1, a2) = from a1 <> from a2 + +instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where + from = fromArray (const 3) f where + f (a1, a2, a3) = from a1 <> from a2 <> from a3 + +instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (a1, a2, a3, a4) where + from = fromArray (const 4) f where + f (a1, a2, a3, a4) = from a1 <> from a2 <> from a3 <> from a4 + +instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (a1, a2, a3, a4, a5) where + from = fromArray (const 5) f where + f (a1, a2, a3, a4, a5) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 + +instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (a1, a2, a3, a4, a5, a6) where + from = fromArray (const 6) f where + f (a1, a2, a3, a4, a5, a6) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from 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 + from = fromArray (const 7) f where + f (a1, a2, a3, a4, a5, a6, a7) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from 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 + from = fromArray (const 8) f where + f (a1, a2, a3, a4, a5, a6, a7, a8) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from 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 + from = fromArray (const 9) f where + f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from a8 <> from a9 + +fromArray :: (a -> Int) -> (a -> Builder) -> a -> Builder +fromArray lf pf arr = do + case lf arr of + len | len <= 15 -> + fromWord8 $ 0x90 .|. fromIntegral len + len | len < 0x10000 -> + fromWord8 0xDC <> + fromWord16be (fromIntegral len) + len -> + fromWord8 0xDD <> + fromWord32be (fromIntegral len) + <> pf arr + +instance (Packable k, Packable v) => Packable (Assoc [(k,v)]) where + from = fromMap length (mconcat . map fromPair) . unAssoc + +instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where + from = fromMap V.length (V.foldl (\a b -> a <> fromPair b) mempty) . unAssoc + +instance (Packable k, Packable v) => Packable (M.Map k v) where + from = fromMap M.size (mconcat . map fromPair . M.toList) + +instance Packable v => Packable (IM.IntMap v) where + from = fromMap IM.size (mconcat . map fromPair . IM.toList) + +instance (Packable k, Packable v) => Packable (HM.HashMap k v) where + from = fromMap HM.size (mconcat . map fromPair . HM.toList) + +fromPair :: (Packable a, Packable b) => (a, b) -> Builder +fromPair (a, b) = from a <> from b + +fromMap :: (a -> Int) -> (a -> Builder) -> a -> Builder +fromMap lf pf m = + case lf m of + len | len <= 15 -> + fromWord8 $ 0x80 .|. fromIntegral len + len | len < 0x10000 -> + fromWord8 0xDE <> + fromWord16be (fromIntegral len) + len -> + fromWord8 0xDF <> + fromWord32be (fromIntegral len) + <> pf m + +instance Packable a => Packable (Maybe a) where + from Nothing = from () + from (Just a) = from a diff --git a/Data/MessagePack/Unpack.hs b/Data/MessagePack/Unpack.hs new file mode 100644 --- /dev/null +++ b/Data/MessagePack/Unpack.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Unpack +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- 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.Applicative +import Control.Exception +import Control.Monad +import qualified Data.Attoparsec as A +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Hashable +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import qualified Data.IntMap as IM +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 Foreign +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 -> do + bs <- A.take 4 + -- TODO: unsafePerformIO => unsafeLocalState + return $! unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr + _ -> + fail $ printf "invlid float tag: 0x%02X" c + +instance Unpackable Double where + get = do + c <- A.anyWord8 + case c of + 0xCB -> do + bs <- A.take 8 + return $! unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr + _ -> + 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) + +instance (Ord k, Unpackable k, Unpackable v) => Unpackable (M.Map k v) where + get = parseMap (\n -> M.fromList <$> replicateM n parsePair) + +instance Unpackable v => Unpackable (IM.IntMap v) where + get = parseMap (\n -> IM.fromList <$> replicateM n parsePair) + +instance (Hashable k, Eq k, Unpackable k, Unpackable v) => Unpackable (HM.HashMap k v) where + get = parseMap (\n -> HM.fromList <$> replicateM n 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/msgpack.cabal b/msgpack.cabal --- a/msgpack.cabal +++ b/msgpack.cabal @@ -1,50 +1,61 @@ Name: msgpack -Version: 0.6.4 +Version: 0.7.0 Synopsis: A Haskell implementation of MessagePack -Description: - A Haskell implementation of MessagePack - +Description: A Haskell implementation of MessagePack +Homepage: http://msgpack.org/ 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 +Copyright: Copyright (c) 2009-2011, Hideyuki Tanaka +Category: Data Stability: Experimental -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple -Extra-source-files: - test/Test.hs - test/UserData.hs +Source-repository head + Type: git + Location: git://github.com/msgpack/msgpack-haskell.git 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 + Build-depends: base >=4 && <5 + , mtl >= 2.0 && < 2.1 + , bytestring >= 0.9 && < 0.10 + , text >= 0.11 && < 0.12 + , containers >= 0.4 && < 0.5 + , unordered-containers >= 0.1 && < 0.2 + , hashable >= 1.1 && < 1.2 + , vector >= 0.7 && < 0.10 + , attoparsec >= 0.8 && < 0.11 + , blaze-builder >= 0.3 && < 0.4 + , 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 + Exposed-modules: Data.MessagePack + Data.MessagePack.Assoc + Data.MessagePack.Pack + Data.MessagePack.Unpack + Data.MessagePack.Object + Data.MessagePack.Derive + Data.MessagePack.Internal.Utf8 -Source-repository head - Type: git - Location: git://github.com/msgpack/msgpack.git +Test-suite msgpack-tests + Type: exitcode-stdio-1.0 + Main-is: test/Test.hs + Build-depends: base >= 4 && < 5 + , mtl >= 2.0 && < 2.1 + , bytestring >= 0.9 && < 0.10 + , text >= 0.11 && < 0.12 + , containers >= 0.4 && < 0.5 + , unordered-containers >= 0.1 && < 0.2 + , hashable >= 1.1 && < 1.2 + , vector >= 0.7 && < 0.10 + , attoparsec >= 0.8 && < 0.11 + , blaze-builder >= 0.3 && < 0.4 + , deepseq >= 1.1 && <1.3 + , template-haskell >= 2.4 && < 2.7 + , QuickCheck >= 2.4 && < 2.5 + , test-framework >= 0.4 && < 0.5 + , test-framework-quickcheck2 >= 0.2 && < 0.3 diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs deleted file mode 100644 --- a/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/src/Data/MessagePack/Assoc.hs b/src/Data/MessagePack/Assoc.hs deleted file mode 100644 --- a/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/src/Data/MessagePack/Derive.hs b/src/Data/MessagePack/Derive.hs deleted file mode 100644 --- a/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/src/Data/MessagePack/Internal/Utf8.hs b/src/Data/MessagePack/Internal/Utf8.hs deleted file mode 100644 --- a/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/src/Data/MessagePack/Object.hs b/src/Data/MessagePack/Object.hs deleted file mode 100644 --- a/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/src/Data/MessagePack/Pack.hs b/src/Data/MessagePack/Pack.hs deleted file mode 100644 --- a/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/src/Data/MessagePack/Unpack.hs b/src/Data/MessagePack/Unpack.hs deleted file mode 100644 --- a/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/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/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/test/UserData.hs b/test/UserData.hs deleted file mode 100644 --- a/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 ()