mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-03-19 04:52:59 +01:00
improve and change user data auto-deriver
This commit is contained in:
Hideyuki Tanaka
parent
cad9f6d46e
commit
79b51a6e4b
@ -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/>
|
||||
|
||||
@ -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
|
||||
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))
|
||||
|]
|
||||
|
||||
return
|
||||
[ InstanceD [] (AppT (ConT ''Packable) (ConT name))
|
||||
[ FunD 'put (map body cons)
|
||||
]]
|
||||
_ -> error $ "cant derive Packable: " ++ show tyName
|
||||
|
||||
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) |])
|
||||
[]
|
||||
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user