First attempts to automatically derive IsYamObject
First attempts to automatically derive IsYamObject
diff --git a/Derive.hs b/Derive.hs
new file mode 100644
index 0000000..65a2dfa
--- /dev/null
+++ b/Derive.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses #-}
+module Derive where
+
+import Language.Haskell.TH
+import Control.Monad
+import Data.Object
+import Data.Object.Yaml
+
+import YAML
+import YAMLInstances
+
+data T1 = T1
+
+mkList :: [Name] -> Q Exp
+mkList [] = [| [] |]
+mkList (v:vars) = [| (toYamlScalar $(stringE $ nameBase v), Scalar $ toYamlScalar $(varE v)): $(mkList vars) |]
+
+getNameBase :: Name -> Name
+getNameBase name = mkName $ nameBase name
+
+consClause :: Con -> ClauseQ
+consClause (NormalC name fields) = do
+ -- Name of constructor, i.e. "A". Will become string literal in generated code
+ let constructorName = nameBase name
+
+ -- Get variables for left and right side of function definition
+ (pats,vars) <- genPE (length fields)
+
+ clause [conP name pats] -- (A x1 x2)
+ (normalB [| Mapping [(toYamlScalar constructorName, Mapping $(mkList vars))] |]) []
+
+consClause (RecC name fields) = do
+ -- Name of constructor, i.e. "A". Will become string literal in generated code
+ let constructorName = nameBase name
+ names = [getNameBase name | (name, _, _) <- fields]
+ pats = map varP names
+ clause [conP name pats] -- (A x1 x2)
+ (normalB [| Mapping [(toYamlScalar constructorName, Mapping $(mkList names))] |]) []
+
+consClause x = report True (show x) >> return undefined
+
+
+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]]
+
+-- | Generate n unique variables and return them in form of patterns and expressions
+genPE :: Int -> Q ([PatQ], [Name])
+genPE n = do
+ ids <- replicateM n (newName "x")
+ return (map varP ids, ids)
+
diff --git a/TestDerive.hs b/TestDerive.hs
new file mode 100644
index 0000000..6854b9c
--- /dev/null
+++ b/TestDerive.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}
+
+import Data.Convertible.Base
+import Data.Object.Yaml
+
+import YAML
+import Derive
+
+data Test = Test {getX :: Int, getY :: Int}
+
+$(deriveToYamlObject ''Test)
+
+t1 = Test 3 5
+
+t2 :: YamlObject
+t2 = cs t1
+
+main = print t2
+
diff --git a/YAML.hs b/YAML.hs
index f157ef1..1ab48cc 100644
--- a/YAML.hs
+++ b/YAML.hs
@@ -41,6 +41,10 @@ instance IsYamlScalar Double where
fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v
toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any
+instance IsYamlScalar Int where
+ fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v
+ toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any
+
serialize :: IsYamlObject a => a -> BS.ByteString
serialize x =
let c :: YamlObject