generic-library/msgpack
1
0
Fork 0
mirror of https://github.com/msgpack/msgpack-c.git synced 2025-03-19 04:52:59 +01:00
Code Issues Projects Releases Wiki Activity

change behaviour of auto-deriver

Browse Source
This commit is contained in:
Hideyuki Tanaka 2011-11-17 17:40:10 +09:00
parent 79b51a6e4b
commit 7869e96bac
3 changed files with 26 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
haskell/msgpack.cabal
View File

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

35
haskell/src/Data/MessagePack/Derive.hs
View File

@ -9,7 +9,10 @@ module Data.MessagePack.Derive (
import Control.Monad import Control.Monad
import Control.Monad.Error () -- for MonadPlus instance of Either e import Control.Monad.Error () -- for MonadPlus instance of Either e
import Data.Char
import Data.List
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.MessagePack.Assoc import Data.MessagePack.Assoc
import Data.MessagePack.Pack import Data.MessagePack.Pack
@ -40,7 +43,7 @@ derivePack tyName = do
match (conP conName $ map varP vars) match (conP conName $ map varP vars)
(normalB (normalB
[| put $ Assoc [| put $ Assoc
$(listE [ [| ( $(return $ LitE $ StringL $ show fname) $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname)
, toObject $(varE v)) |] , toObject $(varE v)) |]
| (v, (fname, _, _)) <- zip vars elms]) | (v, (fname, _, _)) <- zip vars elms])
|]) |])
@ -71,21 +74,15 @@ deriveUnpack tyName = do
var <- newName "v" var <- newName "v"
vars <- replicateM (length elms) (newName "w") vars <- replicateM (length elms) (newName "w")
doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ] doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ]
++ zipWith (binds var) vars elms ++ ++ zipWith (binds conName var) vars elms ++
[ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ] [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ]
alt c = error $ "unsupported constructor: " ++ pprint c alt c = error $ "unsupported constructor: " ++ pprint c
binds var res (fname, _, _) = binds conName var res (fname, _, _) =
bindS (varP res) bindS (varP res)
[| failN $ lookup $(return $ LitE $ StringL $ show fname) $(varE var) |] [| failN $ lookup $(return $ LitE $ StringL $ key conName fname)
$(varE var) |]
failN Nothing = mzero
failN (Just a) =
case tryFromObject a of
Left _ -> mzero
Right v -> return v
deriveObject :: Name -> Q [Dec] deriveObject :: Name -> Q [Dec]
deriveObject typName = do deriveObject typName = do
@ -93,3 +90,19 @@ deriveObject typName = do
p <- deriveUnpack typName p <- deriveUnpack typName
o <- [d| instance OBJECT $(conT typName) where |] o <- [d| instance OBJECT $(conT typName) where |]
return $ g ++ p ++ o return $ g ++ p ++ o
failN Nothing = mzero
failN (Just a) =
case tryFromObject a of
Left _ -> mzero
Right v -> return v
key conName fname
| prefix `isPrefixOf` sFname && length sFname > length prefix =
uncapital $ drop (length prefix) sFname
| otherwise = sFname
where
prefix = map toLower $ nameBase conName
sFname = nameBase fname
uncapital (c:cs) | isUpper c = toLower c : cs
uncapital cs = cs

2
haskell/test/UserData.hs
View File

@ -11,7 +11,7 @@ deriveObject ''T
data U data U
= C { c1 :: Int, c2 :: String } = C { c1 :: Int, c2 :: String }
| D { d1 :: Double } | D { z1 :: Double }
deriving (Show, Eq) deriving (Show, Eq)
deriveObject ''U deriveObject ''U