First attempts to automatically derive IsYamObject

Ilya Portnov [2010-04-21 18:45:26]
First attempts to automatically derive IsYamObject
Filename
Derive.hs
TestDerive.hs
YAML.hs
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
ViewGit