diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal index 9e149087..8229d3ef 100644 --- a/haskell/msgpack.cabal +++ b/haskell/msgpack.cabal @@ -1,5 +1,5 @@ Name: msgpack -Version: 0.6.1.3 +Version: 0.6.2 Synopsis: A Haskell implementation of MessagePack Description: A Haskell implementation of MessagePack diff --git a/haskell/src/Data/MessagePack/Derive.hs b/haskell/src/Data/MessagePack/Derive.hs index 74943e9d..29cb53cb 100644 --- a/haskell/src/Data/MessagePack/Derive.hs +++ b/haskell/src/Data/MessagePack/Derive.hs @@ -1,4 +1,5 @@ {-# Language TemplateHaskell #-} +{-# Language FlexibleInstances #-} module Data.MessagePack.Derive ( derivePack, @@ -6,101 +7,89 @@ module Data.MessagePack.Derive ( deriveObject, ) where -import Control.Applicative import Control.Monad +import Control.Monad.Error () -- for MonadPlus instance of Either e import Language.Haskell.TH +import Data.MessagePack.Assoc import Data.MessagePack.Pack import Data.MessagePack.Unpack import Data.MessagePack.Object -deriveUnpack :: Name -> Q [Dec] -deriveUnpack typName = do - TyConI (DataD _ name _ cons _) <- reify typName - - return - [ InstanceD [] (AppT (ConT ''Unpackable) (ConT name)) - [ FunD 'get [Clause [] (NormalB $ ch $ map body cons) []] - ]] - - where - body (NormalC conName elms) = - 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 - - 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 _ name _ cons _) <- reify typName - - return - [ InstanceD [] (AppT (ConT ''Packable) (ConT name)) - [ FunD 'put (map body cons) - ]] - - where - body (NormalC conName elms) = - Clause - [ ConP conName $ map VarP names ] - (NormalB $ AppE (VarE 'put) $ tupOrListE $ map VarE names) [] - where - names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms +derivePack 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)) + |] + + _ -> error $ "cant derive Packable: " ++ show tyName + + 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") + match (conP conName $ map varP vars) + (normalB + [| put $ Assoc + $(listE [ [| ( $(return $ LitE $ StringL $ show fname) + , toObject $(varE v)) |] + | (v, (fname, _, _)) <- zip vars elms]) + |]) + [] + + alt c = error $ "unsupported constructor: " ++ pprint c + +deriveUnpack :: Name -> Q [Dec] +deriveUnpack 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) + |] + + _ -> error $ "cant derive Packable: " ++ show tyName + + 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") + doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ] + ++ zipWith (binds var) vars elms ++ + [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ] + + alt c = error $ "unsupported constructor: " ++ pprint c + + binds var res (fname, _, _) = + bindS (varP res) + [| failN $ lookup $(return $ LitE $ StringL $ show fname) $(varE var) |] + +failN Nothing = mzero +failN (Just a) = + case tryFromObject a of + Left _ -> mzero + Right v -> return v - 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 _ name _ cons _) <- reify typName - let o = InstanceD [] (AppT (ConT ''OBJECT) (ConT name)) - [ 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 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 $ - 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] -> 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 == 0 = SigE (ListE []) (AppT ListT (ConT ''())) - | length ls == 1 = ListE ls - | otherwise = TupE ls + o <- [d| instance OBJECT $(conT typName) where |] + return $ g ++ p ++ o diff --git a/haskell/test/UserData.hs b/haskell/test/UserData.hs index 5e5d0ea0..af8460ad 100644 --- a/haskell/test/UserData.hs +++ b/haskell/test/UserData.hs @@ -1,27 +1,26 @@ {-# Language TemplateHaskell #-} import Data.MessagePack -import Data.MessagePack.Derive data T = A Int String | B Double deriving (Show, Eq) -$(deriveObject ''T) +deriveObject ''T data U = C { c1 :: Int, c2 :: String } | D { d1 :: Double } deriving (Show, Eq) -$(deriveObject ''U) +deriveObject ''U data V = E String | F deriving (Show, Eq) -$(deriveObject ''V) +deriveObject ''V test :: (OBJECT a, Show a, Eq a) => a -> IO () test v = do @@ -33,6 +32,7 @@ test v = do print oa print (fromObject oa == v) +main :: IO () main = do test $ A 123 "hoge" test $ B 3.14 @@ -40,4 +40,4 @@ main = do test $ D 3.14 test $ E "hello" test $ F - return () \ No newline at end of file + return ()