generic-library/msgpack
1
0
Fork 0
mirror of https://github.com/msgpack/msgpack-c.git synced 2025-10-21 23:56:55 +02:00
Code Issues Projects Releases Wiki Activity

haskell: finish template-haskell deriving implement

Browse Source
This commit is contained in:
tanakh
2010-09-24 01:24:13 +09:00
parent 6aa196cf55
commit 93bed9c5df
4 changed files with 75 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -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