From 1845f34b81f3b1c077852154f144910ccda9c640 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 18 Nov 2011 16:49:12 +0900 Subject: [PATCH] change auto-derive behaviour --- haskell/msgpack.cabal | 2 +- haskell/src/Data/MessagePack/Derive.hs | 42 +++++++++++++++++--------- haskell/test/UserData.hs | 11 ++++--- 3 files changed, 34 insertions(+), 21 deletions(-) diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal index dd868bc2..a87eb833 100644 --- a/haskell/msgpack.cabal +++ b/haskell/msgpack.cabal @@ -1,5 +1,5 @@ Name: msgpack -Version: 0.6.3.1 +Version: 0.6.4 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 b2a608a8..95784a80 100644 --- a/haskell/src/Data/MessagePack/Derive.hs +++ b/haskell/src/Data/MessagePack/Derive.hs @@ -2,25 +2,26 @@ {-# Language FlexibleInstances #-} module Data.MessagePack.Derive ( + -- | deriving OBJECT derivePack, deriveUnpack, deriveObject, ) where import Control.Monad -import Control.Monad.Error () -- for MonadPlus instance of Either e +import Control.Monad.Error () -- MonadPlus instance for Either e import Data.Char import Data.List +import qualified Data.Text as T import Language.Haskell.TH -import Language.Haskell.TH.Syntax import Data.MessagePack.Assoc import Data.MessagePack.Pack import Data.MessagePack.Unpack import Data.MessagePack.Object -derivePack :: Name -> Q [Dec] -derivePack tyName = do +derivePack :: Bool -> Name -> Q [Dec] +derivePack asObject tyName = do info <- reify tyName d <- case info of TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do @@ -40,20 +41,25 @@ derivePack tyName = do alt (RecC conName elms) = do vars <- replicateM (length elms) (newName "v") - match (conP conName $ map varP vars) + if asObject + then + match (conP conName $ map varP vars) (normalB [| put $ Assoc - $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) + $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) :: T.Text , toObject $(varE v)) |] | (v, (fname, _, _)) <- zip vars elms]) |]) [] + else + match (conP conName $ map varP vars) + (normalB [| put $(tupE $ map varE vars) |]) + [] alt c = error $ "unsupported constructor: " ++ pprint c - -deriveUnpack :: Name -> Q [Dec] -deriveUnpack tyName = do +deriveUnpack :: Bool -> Name -> Q [Dec] +deriveUnpack asObject tyName = do info <- reify tyName d <- case info of TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do @@ -74,21 +80,27 @@ deriveUnpack tyName = do alt (RecC conName elms) = do var <- newName "v" vars <- replicateM (length elms) (newName "w") - doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ] + if asObject + then + doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ] ++ zipWith (binds conName var) vars elms ++ [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ] + else + doE [ bindS (tupP $ map varP vars) [| get |] + , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] + ] alt c = error $ "unsupported constructor: " ++ pprint c binds conName var res (fname, _, _) = bindS (varP res) - [| failN $ lookup $(return $ LitE $ StringL $ key conName fname) + [| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text) $(varE var) |] -deriveObject :: Name -> Q [Dec] -deriveObject tyName = do - g <- derivePack tyName - p <- deriveUnpack tyName +deriveObject :: Bool -> Name -> Q [Dec] +deriveObject asObject tyName = do + g <- derivePack asObject tyName + p <- deriveUnpack asObject tyName info <- reify tyName o <- case info of TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> diff --git a/haskell/test/UserData.hs b/haskell/test/UserData.hs index 77589454..55e1d618 100644 --- a/haskell/test/UserData.hs +++ b/haskell/test/UserData.hs @@ -1,4 +1,5 @@ -{-# Language TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} import Data.MessagePack @@ -7,27 +8,27 @@ data T | B Double deriving (Show, Eq) -deriveObject ''T +deriveObject True ''T data U = C { c1 :: Int, c2 :: String } | D { z1 :: Double } deriving (Show, Eq) -deriveObject ''U +deriveObject True ''U data V = E String | F deriving (Show, Eq) -deriveObject ''V +deriveObject True ''V data W a = G a String | H { hHoge :: Int, h_age :: a } deriving (Show, Eq) -deriveObject ''W +deriveObject True ''W test :: (OBJECT a, Show a, Eq a) => a -> IO () test v = do