Support for NormalC when deriving.
Support for NormalC when deriving.
diff --git a/Derive.hs b/Derive.hs
index 58a3749..9af4679 100644
--- a/Derive.hs
+++ b/Derive.hs
@@ -49,19 +49,26 @@ consClause (RecC name fields) = do
consClause x = report True (show x) >> return undefined
-fromClause :: Con -> ClauseQ
-fromClause (RecC name fields) = do
- let constructorName = nameBase name
- names = [getNameBase name | (name, _, _) <- fields]
- pats = map varP names
+genFromClause cName names= do
obj <- newName "obj"
- let guard = [| getFirstKey $(varE obj) == (BS.pack constructorName) |]
- body = foldl appE (conE $ mkName constructorName) $ map (getAttr' constructorName obj) $ map getNameBase names
+ let guard = [| getFirstKey $(varE obj) == (BS.pack cName) |]
+ body = foldl appE (conE $ mkName cName) $ map (getAttr' cName obj) $ map getNameBase names
clause [varP obj]
(guardedB [normalGE guard body]) []
where
getAttr' c obj n = [| fromMaybe def $ getSubKey (BS.pack c) $(stringOfName n) $(varE obj) |]
+fromClause :: Con -> ClauseQ
+fromClause (RecC name fields) = do
+ let constructorName = nameBase name
+ names = [getNameBase name | (name, _, _) <- fields]
+ genFromClause constructorName names
+
+fromClause (NormalC name fields) = do
+ let constructorName = nameBase name
+ (_,names) <- genPE (length fields)
+ genFromClause constructorName names
+
deriveToYamlObject :: Name -> Q [Dec]
deriveToYamlObject t = do
-- Get list of constructors for type t
@@ -85,7 +92,10 @@ deriveIsYamlObject t = do
defaultClause :: Con -> ClauseQ
defaultClause (RecC name fields) = do
let defs = replicate (length fields) (varE $ mkName "def")
- names = [getNameBase name | (name, _, _) <- fields]
+ body = foldl appE (conE name) defs
+ clause [] (normalB body) []
+defaultClause (NormalC name fields) = do
+ let defs = replicate (length fields) (varE $ mkName "def")
body = foldl appE (conE name) defs
clause [] (normalB body) []
diff --git a/TestDerive.hs b/TestDerive.hs
index 0571cde..4b9e816 100644
--- a/TestDerive.hs
+++ b/TestDerive.hs
@@ -11,6 +11,7 @@ import Derive
data Test = Test {getX :: Int, getY :: Int}
| Another {getA :: Double}
+ | Third Int
deriving(Show)
$(deriveDefault ''Test)
@@ -19,6 +20,7 @@ $(deriveIsYamlObject ''Test)
t1 = Test 3 5
t2 = Another 7.5
+t3 = Third 2
test :: Test -> IO ()
test t = do
@@ -29,4 +31,5 @@ test t = do
main = do
test t1
test t2
+ test t3