From 93bed9c5df6d4fe7a0defdaeb2f158e27d4feb1d Mon Sep 17 00:00:00 2001 From: tanakh Date: Fri, 24 Sep 2010 01:24:13 +0900 Subject: [PATCH 1/2] haskell: finish template-haskell deriving implement --- haskell/msgpack.cabal | 4 ++ haskell/src/Data/MessagePack/Derive.hs | 62 ++++++++++++++++++-------- haskell/test/Test.hs | 2 +- haskell/test/UserData.hs | 26 +++++++++++ 4 files changed, 75 insertions(+), 19 deletions(-) diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal index 9c67bdc..9950273 100644 --- a/haskell/msgpack.cabal +++ b/haskell/msgpack.cabal @@ -15,6 +15,10 @@ Stability: Experimental Cabal-Version: >= 1.6 Build-Type: Simple +Extra-source-files: + test/Test.hs + test/UserData.hs + Library Build-depends: base >=4 && <5, transformers >= 0.2.1 && < 0.2.2, diff --git a/haskell/src/Data/MessagePack/Derive.hs b/haskell/src/Data/MessagePack/Derive.hs index cfdb658..e998473 100644 --- a/haskell/src/Data/MessagePack/Derive.hs +++ b/haskell/src/Data/MessagePack/Derive.hs @@ -11,10 +11,11 @@ import Language.Haskell.TH import Data.MessagePack.Pack import Data.MessagePack.Unpack +import Data.MessagePack.Object deriveUnpack :: Name -> Q [Dec] deriveUnpack typName = do - TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName + TyConI (DataD _ name _ cons _) <- reify typName return [ InstanceD [] (AppT (ConT ''Unpackable) (ConT name)) @@ -24,20 +25,19 @@ deriveUnpack typName = do where body (NormalC conName elms) = DoE - [ BindS (tupOrList $ map VarP names) (VarE 'get) + [ BindS (tupOrListP $ map VarP names) (VarE 'get) , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] where names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms - tupOrList ls - | length ls <= 1 = ListP ls - | otherwise = TupP ls + body (RecC conName elms) = + body (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f) derivePack :: Name -> Q [Dec] derivePack typName = do - TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName + TyConI (DataD _ name _ cons _) <- reify typName return [ InstanceD [] (AppT (ConT ''Packable) (ConT name)) @@ -48,27 +48,53 @@ derivePack typName = do body (NormalC conName elms) = Clause [ ConP conName $ map VarP names ] - (NormalB $ AppE (VarE 'put) $ tupOrList $ map VarE names) [] + (NormalB $ AppE (VarE 'put) $ tupOrListE $ map VarE names) [] where names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms - tupOrList ls - | length ls <= 1 = ListE ls - | otherwise = TupE ls + body (RecC conName elms) = + body (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) deriveObject :: Name -> Q [Dec] deriveObject typName = do g <- derivePack typName p <- deriveUnpack typName - {- - TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName + + TyConI (DataD _ name _ cons _) <- reify typName let o = InstanceD [] (AppT (ConT ''OBJECT) (ConT name)) - [ FunD 'toObject (map toObjectBody cons) ] - -} - return $ g ++ p -- ++ [o] -{- + [ FunD 'toObject (map toObjectBody cons), + FunD 'tryFromObject [Clause [ VarP oname ] + (NormalB $ ch $ map tryFromObjectBody cons) []]] + + return $ g ++ p ++ [o] where toObjectBody (NormalC conName elms) = Clause - [ ConP conP --} + [ ConP conName $ map VarP names ] + (NormalB $ AppE (VarE 'toObject) $ tupOrListE $ map VarE names) [] + where + names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms + toObjectBody (RecC conName elms) = + toObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) + + tryFromObjectBody (NormalC conName elms) = + DoE + [ BindS (tupOrListP $ map VarP names) (AppE (VarE 'tryFromObject) (VarE oname)) + , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] + where + names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms + tryFromObjectBody (RecC conName elms) = + tryFromObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) + + oname = mkName "o" + ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f) + +tupOrListP :: [Pat] -> Pat +tupOrListP ls + | length ls <= 1 = ListP ls + | otherwise = TupP ls + +tupOrListE :: [Exp] -> Exp +tupOrListE ls + | length ls <= 1 = ListE ls + | otherwise = TupE ls diff --git a/haskell/test/Test.hs b/haskell/test/Test.hs index a73ac9a..43af2ef 100644 --- a/haskell/test/Test.hs +++ b/haskell/test/Test.hs @@ -7,7 +7,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import Data.MessagePack -mid :: (ObjectGet a, ObjectPut a) => a -> a +mid :: (Packable a, Unpackable a) => a -> a mid = unpack . pack prop_mid_int a = a == mid a diff --git a/haskell/test/UserData.hs b/haskell/test/UserData.hs index 8aced13..73647ff 100644 --- a/haskell/test/UserData.hs +++ b/haskell/test/UserData.hs @@ -10,6 +10,13 @@ data T $(deriveObject ''T) +data U + = C { c1 :: Int, c2 :: String } + | D { d1 :: Double } + deriving (Show) + +$(deriveObject ''U) + main = do let bs = pack $ A 123 "hoge" print bs @@ -17,3 +24,22 @@ main = do let cs = pack $ B 3.14 print cs print (unpack cs :: T) + let oa = toObject $ A 123 "hoge" + print oa + print (fromObject oa :: T) + let ob = toObject $ B 3.14 + print ob + print (fromObject ob :: T) + + let ds = pack $ C 123 "hoge" + print ds + print (unpack ds :: U) + let es = pack $ D 3.14 + print es + print (unpack es :: U) + let oc = toObject $ C 123 "hoge" + print oc + print (fromObject oc :: U) + let od = toObject $ D 3.14 + print od + print (fromObject od :: U) From 894ff716647eeb63b8a04e279faa09092ac9c1c7 Mon Sep 17 00:00:00 2001 From: tanakh Date: Fri, 24 Sep 2010 03:49:31 +0900 Subject: [PATCH 2/2] haskell: fix for empty constructor --- haskell/msgpack.cabal | 2 +- haskell/src/Data/MessagePack/Derive.hs | 28 ++++++++------ haskell/test/UserData.hs | 52 +++++++++++++------------- 3 files changed, 43 insertions(+), 39 deletions(-) diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal index 9950273..98133a9 100644 --- a/haskell/msgpack.cabal +++ b/haskell/msgpack.cabal @@ -1,5 +1,5 @@ Name: msgpack -Version: 0.4.0 +Version: 0.4.0.1 Synopsis: A Haskell binding to MessagePack Description: A Haskell binding to MessagePack diff --git a/haskell/src/Data/MessagePack/Derive.hs b/haskell/src/Data/MessagePack/Derive.hs index e998473..74943e9 100644 --- a/haskell/src/Data/MessagePack/Derive.hs +++ b/haskell/src/Data/MessagePack/Derive.hs @@ -7,6 +7,7 @@ module Data.MessagePack.Derive ( ) where import Control.Applicative +import Control.Monad import Language.Haskell.TH import Data.MessagePack.Pack @@ -24,9 +25,9 @@ deriveUnpack typName = do where body (NormalC conName elms) = - DoE - [ BindS (tupOrListP $ map VarP names) (VarE 'get) - , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] + DoE $ + tupOrListP (map VarP names) (VarE 'get) ++ + [ NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] where names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms @@ -78,9 +79,9 @@ deriveObject typName = do toObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) tryFromObjectBody (NormalC conName elms) = - DoE - [ BindS (tupOrListP $ map VarP names) (AppE (VarE 'tryFromObject) (VarE oname)) - , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] + DoE $ + tupOrListP (map VarP names) (AppE (VarE 'tryFromObject) (VarE oname)) ++ + [ NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] where names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms tryFromObjectBody (RecC conName elms) = @@ -89,12 +90,17 @@ deriveObject typName = do oname = mkName "o" ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f) -tupOrListP :: [Pat] -> Pat -tupOrListP ls - | length ls <= 1 = ListP ls - | otherwise = TupP ls +tupOrListP :: [Pat] -> Exp -> [Stmt] +tupOrListP ls e + | length ls == 0 = + let lsname = mkName "ls" in + [ BindS (VarP lsname) e + , NoBindS $ AppE (VarE 'guard) $ AppE (VarE 'null) $ SigE (VarE lsname) (AppT ListT (ConT ''())) ] + | length ls == 1 = [ BindS (ListP ls) e ] + | otherwise = [ BindS (TupP ls) e ] tupOrListE :: [Exp] -> Exp tupOrListE ls - | length ls <= 1 = ListE ls + | length ls == 0 = SigE (ListE []) (AppT ListT (ConT ''())) + | length ls == 1 = ListE ls | otherwise = TupE ls diff --git a/haskell/test/UserData.hs b/haskell/test/UserData.hs index 73647ff..5e5d0ea 100644 --- a/haskell/test/UserData.hs +++ b/haskell/test/UserData.hs @@ -6,40 +6,38 @@ import Data.MessagePack.Derive data T = A Int String | B Double - deriving (Show) + deriving (Show, Eq) $(deriveObject ''T) data U = C { c1 :: Int, c2 :: String } | D { d1 :: Double } - deriving (Show) + deriving (Show, Eq) $(deriveObject ''U) -main = do - let bs = pack $ A 123 "hoge" - print bs - print (unpack bs :: T) - let cs = pack $ B 3.14 - print cs - print (unpack cs :: T) - let oa = toObject $ A 123 "hoge" - print oa - print (fromObject oa :: T) - let ob = toObject $ B 3.14 - print ob - print (fromObject ob :: T) +data V + = E String | F + deriving (Show, Eq) - let ds = pack $ C 123 "hoge" - print ds - print (unpack ds :: U) - let es = pack $ D 3.14 - print es - print (unpack es :: U) - let oc = toObject $ C 123 "hoge" - print oc - print (fromObject oc :: U) - let od = toObject $ D 3.14 - print od - print (fromObject od :: U) +$(deriveObject ''V) + +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 = do + test $ A 123 "hoge" + test $ B 3.14 + test $ C 123 "hoge" + test $ D 3.14 + test $ E "hello" + test $ F + return () \ No newline at end of file