msgpack 0.6.3 → 0.6.4

raw patch · 4 files changed

+81/−42 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• msgpack.cabal +1/−1
• src/Data/MessagePack/Derive.hs +58/−29
• src/Data/MessagePack/Unpack.hs +8/−8
• test/UserData.hs +14/−4

@@ -1,5 +1,5 @@ Name:               msgpack-Version:            0.6.3+Version:            0.6.4 Synopsis:           A Haskell implementation of MessagePack Description:   A Haskell implementation of MessagePack <http://msgpack.org/>

@@ -2,34 +2,35 @@ {-# Language FlexibleInstances #-}  module Data.MessagePack.Derive (+  -- | deriving OBJECT   derivePack,   deriveUnpack,   deriveObject,   ) where  import Control.Monad-import Control.Monad.Error () -- for MonadPlus instance of Either e+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 Language.Haskell.TH.Syntax  import Data.MessagePack.Assoc import Data.MessagePack.Pack import Data.MessagePack.Unpack import Data.MessagePack.Object -derivePack :: Name -> Q [Dec]-derivePack tyName = do+derivePack :: Bool -> Name -> Q [Dec]+derivePack asObject tyName = do   info <- reify tyName-  case info of-    TyConI (DataD _ {- cxt -} name _ {- tyVarBndr -} cons _ {- derivings -}) -> do-      [d|-       instance Packable $(conT name) where-         put v = $(caseE [| v |] (map alt cons))-       |]+  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@@ -40,28 +41,34 @@      alt (RecC conName elms) = do       vars <- replicateM (length elms) (newName "v")-      match (conP conName $ map varP vars)+      if asObject+        then+        match (conP conName $ map varP vars)         (normalB          [| put $ Assoc-              $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname)+              $(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 :: Name -> Q [Dec]-deriveUnpack tyName = do+deriveUnpack :: Bool -> Name -> Q [Dec]+deriveUnpack asObject tyName = do   info <- reify tyName-  case info of-    TyConI (DataD _ {- cxt -} name _ {- tyVarBndr -} cons _ {- derivings -}) -> do-      [d|-       instance Unpackable $(conT name) where-         get = $(foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons)-       |]+  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 Packable: " ++ show tyName+    _ -> error $ "cant derive Unpackable: " ++ show tyName+  return [d]    where     alt (NormalC conName elms) = do@@ -73,23 +80,34 @@     alt (RecC conName elms) = do       var <- newName "v"       vars <- replicateM (length elms) (newName "w")-      doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ]+      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)+            [| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text)                               $(varE var) |] -deriveObject :: Name -> Q [Dec]-deriveObject typName = do-  g <- derivePack typName-  p <- deriveUnpack typName-  o <- [d| instance OBJECT $(conT typName) where |]-  return $ g ++ p ++ o+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) =@@ -97,7 +115,18 @@     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

@@ -193,42 +193,42 @@ 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 " n+    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 " n+    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 " n+    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 " n+    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 " n+    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 " n+    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 " n+    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 " n+    f n = fail $ printf "wrong tupple size: expected 9 but got %d" n  parseArray :: (Int -> A.Parser a) -> A.Parser a parseArray aget = do

@@ -1,4 +1,5 @@-{-# Language TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}  import Data.MessagePack @@ -7,21 +8,28 @@   | B Double   deriving (Show, Eq) -deriveObject ''T+deriveObject True ''T  data U   = C { c1 :: Int, c2 :: String }   | D { z1 :: Double }   deriving (Show, Eq) -deriveObject ''U+deriveObject True ''U  data V   = E String | F   deriving (Show, Eq) -deriveObject ''V+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@@ -40,4 +48,6 @@   test $ D 3.14   test $ E "hello"   test $ F+  test $ G (E "hello") "world"+  test $ H 123 F   return ()