First implementation of deriving IsYamlObject.
First implementation of deriving IsYamlObject.
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])