Fix working with NormalC constructors.

Ilya Portnov [2010-04-22 14:58:49]
Fix working with NormalC constructors.
Filename
Network/YAML/Base.hs
Network/YAML/Derive.hs
Network/YAML/Instances.hs
TestDerive.hs
diff --git a/Network/YAML/Base.hs b/Network/YAML/Base.hs
index 87c2716..847ff41 100644
--- a/Network/YAML/Base.hs
+++ b/Network/YAML/Base.hs
@@ -37,6 +37,12 @@ getSubKey key subkey obj = do
   r <- getAttr subkey attr
   getScalar r

+getItem :: (IsYamlScalar a) => BS.ByteString -> Int -> YamlObject -> Maybe a
+getItem key k obj =
+  case getListAttr key obj of
+    [] -> Nothing
+    lst -> getScalar (lst !! k)
+
 getListAttr :: BS.ByteString -> YamlObject -> [YamlObject]
 getListAttr key obj =
   case getAttr key obj of
diff --git a/Network/YAML/Derive.hs b/Network/YAML/Derive.hs
index 6b9857b..a68bb9e 100644
--- a/Network/YAML/Derive.hs
+++ b/Network/YAML/Derive.hs
@@ -15,10 +15,14 @@ import qualified Data.ByteString.Char8 as BS
 import Network.YAML.Base
 import Network.YAML.Instances

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

+mkSeq :: [Name] -> ExpQ
+mkSeq []       = [| [] |]
+mkSeq (v:vars) = [| cs $(varE v): $(mkSeq vars) |]
+
 getNameBase :: Name -> Name
 getNameBase name = mkName $ nameBase name

@@ -37,7 +41,7 @@ consClause (NormalC name fields) =  do
     (pats,vars) <- genPE (length fields)

     clause [conP name pats]                                 -- (A x1 x2)
-           (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Mapping $(mkList vars))] |]) []
+           (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Sequence $(mkSeq vars))] |]) []

 consClause (RecC name fields) = do
     -- Name of constructor, i.e. "A". Will become string literal in generated code
@@ -53,8 +57,7 @@ genFromClause cName names= do
     obj <- newName "obj"
     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]) []
+    clause [varP obj] (guardedB [normalGE guard body]) []
   where
     getAttr' c obj n = [| fromMaybe def $ getSubKey (BS.pack c) $(stringOfName n) $(varE obj) |]

@@ -65,9 +68,16 @@ fromClause (RecC name fields) = do
     genFromClause constructorName names

 fromClause (NormalC name fields) = do
-    let constructorName = nameBase name
+    let cName = nameBase name
     (_,names) <- genPE (length fields)
-    genFromClause constructorName names
+    obj <- newName "obj"
+    let guard = [| getFirstKey $(varE obj) == (BS.pack cName) |]
+        body = foldl appE (conE $ mkName cName) $ map (getAttr' cName obj) $ map fst (zip [0..] names)
+    clause [varP obj] (guardedB [normalGE guard body]) []
+  where
+    getAttr' c obj k = [| fromMaybe def $ getItem (BS.pack c) k $(varE obj) |]
+    getName (n,x) = (n, getNameBase x)
+

 -- | Derive `instance ConvertSuccess t YamlObject ...'
 deriveToYamlObject :: Name -> Q [Dec]
diff --git a/Network/YAML/Instances.hs b/Network/YAML/Instances.hs
index 8771753..e774126 100644
--- a/Network/YAML/Instances.hs
+++ b/Network/YAML/Instances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings, FlexibleInstances #-}

 module Network.YAML.Instances where

@@ -16,6 +16,9 @@ object pairs = Mapping [(toYamlScalar name, Scalar val) | (name,val) <- pairs]
 field :: (IsYamlScalar a) => BS.ByteString -> a -> YamlObject
 field name val = Mapping [(toYamlScalar name, Scalar $ toYamlScalar val)]

+instance Default BS.ByteString where
+  def = BS.empty
+
 instance (IsYamlObject a) => ConvertSuccess [a] YamlObject where
   convertSuccess lst = Sequence $ map cs lst

@@ -31,6 +34,30 @@ instance Default YamlObject where

 instance IsYamlObject YamlObject where

+instance ConvertSuccess YamlObject Double where
+  convertSuccess x = fromMaybe def $ getScalar x
+
+instance ConvertSuccess Double YamlObject where
+  convertSuccess x = Scalar $ toYamlScalar x
+
+instance IsYamlObject Double where
+
+instance ConvertSuccess YamlObject Int where
+  convertSuccess x = fromMaybe def $ getScalar x
+
+instance ConvertSuccess Int YamlObject where
+  convertSuccess x = Scalar $ toYamlScalar x
+
+instance IsYamlObject Int where
+
+instance ConvertSuccess YamlObject BS.ByteString where
+  convertSuccess x = fromMaybe def $ getScalar x
+
+instance ConvertSuccess BS.ByteString YamlObject where
+  convertSuccess x = Scalar $ toYamlScalar x
+
+instance IsYamlObject BS.ByteString where
+
 data Call = Call { methodName :: BS.ByteString, args :: YamlObject }
   deriving (Show)

diff --git a/TestDerive.hs b/TestDerive.hs
index 1af713d..e61d108 100644
--- a/TestDerive.hs
+++ b/TestDerive.hs
@@ -11,7 +11,7 @@ import Network.YAML.Derive

 data Test = Test {getX :: Int, getY :: Int}
           | Another {getA :: Double}
-          | Third Int
+          | Third Int Double
   deriving(Show)

 $(deriveDefault ''Test)
@@ -20,7 +20,7 @@ $(deriveIsYamlObject ''Test)

 t1 = Test 3 5
 t2 = Another 7.5
-t3 = Third 2
+t3 = Third 2 1.5

 test :: Test -> IO ()
 test t = do
ViewGit