Fix working with NormalC constructors.
Fix working with NormalC constructors.
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