Permalink
Browse files

Added 'merge keys' feature (http://yaml.org/type/merge.html)

  • Loading branch information...
1 parent 225d144 commit 94ab9325a4f3045ca6815a7f49a4b6ef31d7b3a8 @antage antage committed May 12, 2010
Showing with 76 additions and 22 deletions.
  1. +25 −3 Data/Object/Yaml.hs
  2. +51 −19 runtests.hs
View
@@ -38,7 +38,7 @@ import "transformers" Control.Monad.Trans
#endif
import "transformers" Control.Monad.Trans.State
import Control.Monad
-import Data.Iteratee
+import Data.Iteratee hiding (foldl)
import qualified Data.Iteratee as I
import Control.Monad.CatchIO hiding (try)
import Prelude hiding (catch)
@@ -55,7 +55,7 @@ instance Eq YamlScalar where
type YamlObject = Object YamlScalar YamlScalar
-class IsYamlScalar a where
+class (Eq a) => IsYamlScalar a where
fromYamlScalar :: YamlScalar -> a
toYamlScalar :: a -> YamlScalar
instance IsYamlScalar YamlScalar where
@@ -74,6 +74,18 @@ instance IsYamlScalar ByteString where
fromYamlScalar = value
toYamlScalar b = YamlScalar b NoTag Any
+-- | Merge assoc-lists by keys.
+-- First list overrides second:
+-- [(k1, x), (k2, y)] `mergeAssocLists` [(k3, z)] == [(k1, x), (k2, y), (k3, z)]
+-- [(k1, x), (k2, y)] `mergeAssocLists` [(k2, z)] == [(k1, x), (k2, y)]
+mergeAssocLists :: (Eq k) => [(k, v)] -> [(k, v)] -> [(k, v)]
+mergeAssocLists a [] = a
+mergeAssocLists [] b = b
+mergeAssocLists a ((bk, bv):bs) =
+ case lookup bk a of
+ Nothing -> mergeAssocLists ((bk, bv) : a) bs
+ Just _ -> mergeAssocLists a bs
+
toYamlObject :: IsYamlScalar k
=> IsYamlScalar v
=> Object k v
@@ -244,7 +256,17 @@ parseM a front = do
Just (EventScalar v t s a') -> parseScalar v t s a'
_ -> lift $ pfailure $ UnexpectedEvent me' Nothing
o <- parseO
- parseM a $ front . (:) (s, o)
+ let al = mergeAssocLists [(s, o)] $ front []
+ al' = if fromYamlScalar s == "<<"
+ then case o of
+ Scalar _ -> al
+ Mapping l -> mergeAssocLists al l
+ Sequence l -> mergeAssocLists al $ foldl merge' [] l
+ else al
+ parseM a (`mergeAssocLists` al')
+ where merge' :: (Eq k) => [(k, Object k v)] -> Object k v -> [(k, Object k v)]
+ merge' al (Mapping om) = mergeAssocLists al om
+ merge' al _ = al
decode :: MonadFailure ParseException m
=> ByteString
View
@@ -17,7 +17,17 @@ mkFoldedScalar :: String -> YamlScalar
mkFoldedScalar s = YamlScalar (cs s) LY.StrTag LY.Folded
mkScalar :: String -> YamlScalar
-mkScalar = toYamlScalar
+mkScalar s = YamlScalar (cs s) LY.NoTag LY.Plain
+
+mkStrScalar :: String -> YamlScalar
+mkStrScalar s = YamlScalar (cs s) LY.StrTag LY.Plain
+
+mappingKey :: YamlObject -> String -> YamlObject
+mappingKey (Mapping m) k = (fromJust . lookup (mkScalar k) $ m)
+mappingKey _ _ = error "expected Mapping"
+
+decodeYaml :: String -> Maybe YamlObject
+decodeYaml s = decode $ B8.pack s
sample :: YamlObject
sample = Sequence
@@ -34,6 +44,7 @@ main :: IO ()
main = defaultMain
[ testSuite
, testSuiteOfAliases
+ , testSuiteOfMergeKeys
]
testSuite :: Test
@@ -79,50 +90,71 @@ testSuiteOfAliases = testGroup "Tests of aliases"
caseSimpleScalarAlias :: Assertion
caseSimpleScalarAlias = do
- let maybeRes = decode yamlBS :: Maybe YamlObject
+ let maybeRes = decodeYaml "- &anch foo\n- baz\n- *anch"
isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
let res = fromJust maybeRes
res @?= Sequence [Scalar (mkScalar "foo"), Scalar (mkScalar "baz"), Scalar (mkScalar "foo")]
- where yamlString = "- &anch foo\n- baz\n- *anch"
- yamlBS = B8.pack yamlString
caseSimpleSequenceAlias :: Assertion
caseSimpleSequenceAlias = do
- let maybeRes = decode yamlBS :: Maybe YamlObject
+ let maybeRes = decodeYaml "seq: &anch\n - foo\n - baz\nseq2: *anch"
isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
let res = fromJust maybeRes
res @?= Mapping [(mkScalar "seq", Sequence [Scalar (mkScalar "foo"), Scalar (mkScalar "baz")]), (mkScalar "seq2", Sequence [Scalar (mkScalar "foo"), Scalar (mkScalar "baz")])]
- where yamlString = "seq: &anch\n - foo\n - baz\nseq2: *anch"
- yamlBS = B8.pack yamlString
caseSimpleMappingAlias :: Assertion
caseSimpleMappingAlias = do
- let maybeRes = decode yamlBS :: Maybe YamlObject
+ let maybeRes = decodeYaml "map: &anch\n key1: foo\n key2: baz\nmap2: *anch"
isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
let res = fromJust maybeRes
res @?= Mapping [(mkScalar "map", Mapping [(mkScalar "key1", Scalar (mkScalar "foo")), (mkScalar "key2", Scalar (mkScalar "baz"))]), (mkScalar "map2", Mapping [(mkScalar "key1", Scalar (mkScalar "foo")), (mkScalar "key2", Scalar (mkScalar "baz"))])]
- where yamlString = "map: &anch\n key1: foo\n key2: baz\nmap2: *anch"
- yamlBS = B8.pack yamlString
caseMappingAliasBeforeAnchor :: Assertion
caseMappingAliasBeforeAnchor = do
- let res = decode yamlBS :: Maybe YamlObject
+ let res = decodeYaml "map: *anch\nmap2: &anch\n key1: foo\n key2: baz"
isNothing res @? "decode should return Nothing due to unknown alias"
- where yamlString = "map: *anch\nmap2: &anch\n key1: foo\n key2: baz"
- yamlBS = B8.pack yamlString
caseMappingAliasInsideAnchor :: Assertion
caseMappingAliasInsideAnchor = do
- let res = decode yamlBS :: Maybe YamlObject
+ let res = decodeYaml "map: &anch\n key1: foo\n key2: *anch"
isNothing res @? "decode should return Nothing due to unknown alias"
- where yamlString = "map: &anch\n key1: foo\n key2: *anch"
- yamlBS = B8.pack yamlString
caseScalarAliasOverriding :: Assertion
caseScalarAliasOverriding = do
- let maybeRes = decode yamlBS :: Maybe YamlObject
+ let maybeRes = decodeYaml "- &anch foo\n- baz\n- *anch\n- &anch boo\n- buz\n- *anch"
isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
let res = fromJust maybeRes
res @?= Sequence [Scalar (mkScalar "foo"), Scalar (mkScalar "baz"), Scalar (mkScalar "foo"), Scalar (mkScalar "boo"), Scalar (mkScalar "buz"), Scalar (mkScalar "boo")]
- where yamlString = "- &anch foo\n- baz\n- *anch\n- &anch boo\n- buz\n- *anch"
- yamlBS = B8.pack yamlString
+
+
+testSuiteOfMergeKeys :: Test
+testSuiteOfMergeKeys = testGroup "Tests of 'merge keys' feature"
+ [ testCase "test uniqueness of keys" caseAllKeysShouldBeUnique
+ , testCase "test mapping merge" caseSimpleMappingMerge
+ , testCase "test sequence of mappings merging" caseMergeSequence
+ ]
+
+caseAllKeysShouldBeUnique :: Assertion
+caseAllKeysShouldBeUnique = do
+ let maybeRes = decodeYaml "foo1: foo\nfoo2: baz\nfoo1: buz"
+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
+ let res = fromJust maybeRes
+ mappingKey res "foo1" @?= Scalar (mkScalar "buz")
+
+caseSimpleMappingMerge :: Assertion
+caseSimpleMappingMerge = do
+ let maybeRes = decodeYaml "foo1: foo\nfoo2: baz\n<<:\n foo1: buz\n foo3: fuz"
+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
+ let res = fromJust maybeRes
+ mappingKey res "foo1" @?= Scalar (mkScalar "foo")
+ mappingKey res "foo3" @?= Scalar (mkScalar "fuz")
+
+caseMergeSequence :: Assertion
+caseMergeSequence = do
+ let maybeRes = decodeYaml "m1: &m1\n k1: !!str 1\n k2: !!str 2\nm2: &m2\n k1: !!str 3\n k3: !!str 4\nfoo1: foo\n<<: [ *m1, *m2 ]"
+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
+ let res = fromJust maybeRes
+ mappingKey res "foo1" @?= Scalar (mkScalar "foo")
+ mappingKey res "k1" @?= Scalar (mkStrScalar "1")
+ mappingKey res "k2" @?= Scalar (mkStrScalar "2")
+ mappingKey res "k3" @?= Scalar (mkStrScalar "4")

0 comments on commit 94ab932

Please sign in to comment.