msgpack 0.6.1.3 → 0.6.2
raw patch · 3 files changed
+73/−84 lines, 3 files
Files
- msgpack.cabal +1/−1
- src/Data/MessagePack/Derive.hs +68/−79
- test/UserData.hs +4/−4
msgpack.cabal view
@@ -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 <http://msgpack.org/>
src/Data/MessagePack/Derive.hs view
@@ -1,4 +1,5 @@ {-# Language TemplateHaskell #-}+{-# Language FlexibleInstances #-} module Data.MessagePack.Derive ( derivePack,@@ -6,101 +7,89 @@ 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)+derivePack :: Name -> Q [Dec]+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))+ |] - ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f)+ _ -> error $ "cant derive Packable: " ++ show tyName -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+ alt (NormalC conName elms) = do+ vars <- replicateM (length elms) (newName "v")+ match (conP conName $ map varP vars)+ (normalB [| put $(tupE $ map varE vars) |])+ [] - body (RecC conName elms) =- body (NormalC conName $ map (\(_, b, c) -> (b, c)) elms)+ 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])+ |])+ [] -deriveObject :: Name -> Q [Dec]-deriveObject typName = do- g <- derivePack typName- p <- deriveUnpack typName+ alt c = error $ "unsupported constructor: " ++ pprint c - 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) []]]+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)+ |] - return $ g ++ p ++ [o]+ _ -> error $ "cant derive Packable: " ++ show tyName+ 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)+ 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) |]+ ] - 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)+ 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) |] ] - oname = mkName "o"- ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f)+ alt c = error $ "unsupported constructor: " ++ pprint c -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 ]+ binds var res (fname, _, _) =+ bindS (varP res)+ [| failN $ lookup $(return $ LitE $ StringL $ show fname) $(varE var) |] -tupOrListE :: [Exp] -> Exp-tupOrListE ls- | length ls == 0 = SigE (ListE []) (AppT ListT (ConT ''()))- | length ls == 1 = ListE ls- | otherwise = TupE ls+failN Nothing = mzero+failN (Just a) =+ case tryFromObject a of+ Left _ -> mzero+ Right v -> return v+++deriveObject :: Name -> Q [Dec]+deriveObject typName = do+ g <- derivePack typName+ p <- deriveUnpack typName+ o <- [d| instance OBJECT $(conT typName) where |]+ return $ g ++ p ++ o
test/UserData.hs view
@@ -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 @@ print oa print (fromObject oa == v) +main :: IO () main = do test $ A 123 "hoge" test $ B 3.14