Support for NormalC when deriving.

Ilya V. Portnov [2010-04-22 07:25:02]
Support for NormalC when deriving.
Filename
Derive.hs
TestDerive.hs
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
ViewGit