First implementation of deriving IsYamlObject.

Ilya Portnov [2010-04-22 03:58:16]
First implementation of deriving IsYamlObject.
Filename
Derive.hs
diff --git a/Derive.hs b/Derive.hs
index 65a2dfa..2259d62 100644
--- a/Derive.hs
+++ b/Derive.hs
@@ -3,6 +3,8 @@ module Derive where

 import Language.Haskell.TH
 import Control.Monad
+import Data.Maybe
+import Data.Default
 import Data.Object
 import Data.Object.Yaml

@@ -13,11 +15,14 @@ data T1 = T1

 mkList :: [Name] -> Q Exp
 mkList []       = [| [] |]
-mkList (v:vars) = [| (toYamlScalar $(stringE $ nameBase v), Scalar $ toYamlScalar $(varE v)): $(mkList vars) |]
+mkList (v:vars) = [| (toYamlScalar $(stringOfName v), Scalar $ toYamlScalar $(varE v)): $(mkList vars) |]

 getNameBase :: Name -> Name
 getNameBase name = mkName $ nameBase name

+stringOfName :: Name -> ExpQ
+stringOfName n = stringE $ nameBase n
+
 consClause :: Con -> ClauseQ
 consClause (NormalC name fields) =  do
     -- Name of constructor, i.e. "A". Will become string literal in generated code
@@ -39,12 +44,29 @@ 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
+    obj <- newName "obj"
+    clause [varP obj]
+        (normalB $ foldl appE (varE name) $ map (getAttr' obj) $ map getNameBase names) []
+  where
+    getAttr' obj n = [| fromMaybe def $ getScalarAttr $(stringOfName n) $(varE obj) |]
+

 deriveToYamlObject t = do
   -- Get list of constructors for type t
   TyConI (DataD _ _ _ constructors _)  <-  reify t
   convbody <- mapM consClause constructors
-  return [InstanceD [] (ConT ''ConvertSuccess `AppT` ConT t `AppT` ConT ''YamlObject) [FunD 'convertSuccess convbody]]
+  return $ InstanceD [] (ConT ''ConvertSuccess `AppT` ConT t `AppT` ConT ''YamlObject) [FunD 'convertSuccess convbody]
+
+deriveFromYamlObject t = do
+  TyConI (DataD _ _ _ constructors _)  <-  reify t
+  body <- mapM fromClause constructors
+  return $ InstanceD [] (ConT ''ConvertSuccess `AppT` ConT ''YamlObject `AppT` ConT t) [FunD 'convertSuccess body]
+

 -- | Generate n unique variables and return them in form of patterns and expressions
 genPE ::  Int -> Q ([PatQ], [Name])
ViewGit