Permalink
Browse files

Added aliases and anchors support

  • Loading branch information...
1 parent 3110d03 commit ef0fb299fbbbd37d65b48efbf81feee1c4c9d43c @antage antage committed May 10, 2010
Showing with 128 additions and 27 deletions.
  1. +52 −23 Data/Object/Yaml.hs
  2. +2 −1 data-object-yaml.cabal
  3. +74 −3 runtests.hs
View
@@ -24,6 +24,7 @@ import qualified Text.Libyaml as Y
import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
import Data.Object
import Data.ByteString (ByteString)
+import qualified Data.Map as Map
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (Exception, SomeException (..))
import Data.Typeable (Typeable)
@@ -33,6 +34,7 @@ import Control.Applicative
import qualified Data.Text
import qualified Data.Text.Lazy
import "transformers" Control.Monad.Trans
+import "transformers" Control.Monad.Trans.State
import Control.Monad
#if TEST
@@ -102,9 +104,9 @@ geO :: (MonadIO m, MonadFailure YamlException m, IsYamlScalar k,
=> Object k v
-> YamlEncoder m ()
geO (Scalar s) = geS s
-geO (Sequence yos) = emitEvents EventSequenceStart EventSequenceEnd
+geO (Sequence yos) = emitEvents (EventSequenceStart Nothing) EventSequenceEnd
$ mapM_ geO yos
-geO (Mapping pairs) = emitEvents EventMappingStart EventMappingEnd
+geO (Mapping pairs) = emitEvents (EventMappingStart Nothing) EventMappingEnd
$ mapM_ gePair pairs
gePair :: (MonadIO m, MonadFailure YamlException m, IsYamlScalar k,
@@ -119,7 +121,7 @@ geS :: (MonadIO m, IsYamlScalar a, MonadFailure YamlException m)
geS = emitEvent . toEventScalar . toYamlScalar
toEventScalar :: YamlScalar -> Event
-toEventScalar (YamlScalar v t s) = EventScalar v t s
+toEventScalar (YamlScalar v t s) = EventScalar v t s Nothing
decode :: (MonadFailure YamlException m, IsYamlScalar k, IsYamlScalar v)
=> ByteString
@@ -170,14 +172,16 @@ data UnexpectedEvent = UnexpectedEvent
deriving (Show, Typeable)
instance Exception UnexpectedEvent
+type Parser s m = StateT (Map.Map String s) (YamlDecoder m)
+
parse :: (With m, MonadFailure YamlException m, IsYamlScalar k,
IsYamlScalar v)
=> YamlDecoder m (Object k v)
parse = do
requireEvent EventStreamStart
requireEvent EventDocumentStart
e <- parseEvent
- res <- parseO e
+ res <- evalStateT (parseO e) Map.empty
requireEvent EventDocumentEnd
requireEvent EventStreamEnd
requireEvent EventNone
@@ -186,42 +190,67 @@ parse = do
parseO :: (IsYamlScalar k, IsYamlScalar v, With m,
MonadFailure YamlException m)
=> Event
- -> YamlDecoder m (Object k v)
-parseO (EventScalar v t s) =
- return $ Scalar $ fromYamlScalar $ YamlScalar v t s
-parseO EventSequenceStart = parseS id
-parseO EventMappingStart = parseM id
+ -> Parser (Object k v) m (Object k v)
+parseO (EventScalar v t s a) = do
+ let res = Scalar $ fromYamlScalar $ YamlScalar v t s
+ case a of
+ Nothing -> return res
+ Just an -> do
+ modify (Map.insert an res)
+ return res
+parseO (EventSequenceStart a) = parseS a id
+parseO (EventMappingStart a) = parseM a id
+parseO (EventAlias an) = do
+ m <- get
+ case Map.lookup an m of
+ Nothing -> failure $ YamlOtherException $ SomeException $ UnknownAlias an
+ Just v -> return v
parseO e = failure $ YamlOtherException $ SomeException
$ UnexpectedEvent e Nothing
parseS :: (IsYamlScalar k, IsYamlScalar v, With m,
MonadFailure YamlException m)
- => ([Object k v] -> [Object k v])
- -> YamlDecoder m (Object k v)
-parseS front = do
- e <- parseEvent
+ => Y.Anchor
+ -> ([Object k v] -> [Object k v])
+ -> Parser (Object k v) m (Object k v)
+parseS a front = do
+ e <- lift $ parseEvent
case e of
- EventSequenceEnd -> return $ Sequence $ front []
+ EventSequenceEnd -> do
+ let res = Sequence $ front []
+ case a of
+ Nothing -> return res
+ Just an -> do
+ modify (Map.insert an res)
+ return res
_ -> do
o <- parseO e
- parseS $ front . (:) o
+ parseS a $ front . (:) o
parseM :: (IsYamlScalar k, IsYamlScalar v, With m,
MonadFailure YamlException m)
- => ([(k, Object k v)] -> [(k, Object k v)])
- -> YamlDecoder m (Object k v)
-parseM front = do
- e <- parseEvent
+ => Y.Anchor
+ -> ([(k, Object k v)] -> [(k, Object k v)])
+ -> Parser (Object k v) m (Object k v)
+parseM a front = do
+ e <- lift $ parseEvent
case e of
- EventMappingEnd -> return $ Mapping $ front []
- EventScalar v' t s -> do
+ EventMappingEnd -> do
+ let res = Mapping $ front []
+ case a of
+ Nothing -> return res
+ Just an -> do
+ modify (Map.insert an res)
+ return res
+ EventScalar v' t s Nothing -> do
let k = fromYamlScalar $ YamlScalar v' t s
- v <- parseEvent >>= parseO
- parseM $ front . (:) (k, v)
+ v <- (lift $ parseEvent) >>= parseO
+ parseM a $ front . (:) (k, v)
_ -> failure $ YamlOtherException
$ SomeException NonScalarKey
data ParseException = NonScalarKey
+ | UnknownAlias { _anchorName :: Y.AnchorName }
deriving (Show, Typeable)
instance Exception ParseException
View
@@ -25,7 +25,8 @@ library
attempt >= 0.2.0 && < 0.3,
failure >= 0.0.0 && < 0.1,
transformers >= 0.1.4.0 && < 0.2,
- yaml >= 0.2.0 && < 0.3
+ yaml >= 0.4.0 && < 0.5,
+ containers >= 0.2.0.0 && < 0.4
exposed-modules: Data.Object.Yaml
ghc-options: -Wall
View
@@ -1,8 +1,79 @@
-import Test.Framework (defaultMain)
+{-# LANGUAGE NamedFieldPuns #-}
+import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
-import qualified Data.Object.Yaml
+import Data.Maybe
+import qualified Data.ByteString.Char8 as B8
+
+import Data.Object
+import qualified Data.Object.Yaml as Y
+
+ys :: (Y.IsYamlScalar a) => a -> Y.YamlScalar
+ys = Y.toYamlScalar
main :: IO ()
main = defaultMain
- [ Data.Object.Yaml.testSuite
+ [ Y.testSuite
+ , testSuite
]
+
+testSuite :: Test
+testSuite = testGroup "Tests using samples"
+ [ testCase "simple scalar alias" caseSimpleScalarAlias
+ , testCase "simple sequence alias" caseSimpleSequenceAlias
+ , testCase "simple mapping alias" caseSimpleMappingAlias
+ , testCase "mapping alias before anchor" caseMappingAliasBeforeAnchor
+ , testCase "mapping alias inside anchor" caseMappingAliasInsideAnchor
+ , testCase "scalar alias overriding" caseScalarAliasOverriding
+ ]
+
+caseSimpleScalarAlias :: Assertion
+caseSimpleScalarAlias = do
+ let maybeRes = Y.decode yamlBS :: Maybe (Y.YamlObject)
+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
+ let res = fromJust maybeRes
+ res @?= Sequence [Scalar (ys "foo"), Scalar (ys "baz"), Scalar (ys "foo")]
+ where yamlString = "- &anch foo\n- baz\n- *anch"
+ yamlBS = B8.pack yamlString
+
+caseSimpleSequenceAlias :: Assertion
+caseSimpleSequenceAlias = do
+ let maybeRes = Y.decode yamlBS :: Maybe (Y.YamlObject)
+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
+ let res = fromJust maybeRes
+ res @?= Mapping [(ys "seq", Sequence [Scalar (ys "foo"), Scalar (ys "baz")]), (ys "seq2", Sequence [Scalar (ys "foo"), Scalar (ys "baz")])]
+ where yamlString = "seq: &anch\n - foo\n - baz\nseq2: *anch"
+ yamlBS = B8.pack yamlString
+
+caseSimpleMappingAlias :: Assertion
+caseSimpleMappingAlias = do
+ let maybeRes = Y.decode yamlBS :: Maybe (Y.YamlObject)
+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
+ let res = fromJust maybeRes
+ res @?= Mapping [(ys "map", Mapping [(ys "key1", Scalar (ys "foo")), (ys "key2", Scalar (ys "baz"))]), (ys "map2", Mapping [(ys "key1", Scalar (ys "foo")), (ys "key2", Scalar (ys "baz"))])]
+ where yamlString = "map: &anch\n key1: foo\n key2: baz\nmap2: *anch"
+ yamlBS = B8.pack yamlString
+
+caseMappingAliasBeforeAnchor :: Assertion
+caseMappingAliasBeforeAnchor = do
+ let res = Y.decode yamlBS :: Maybe (Y.YamlObject)
+ 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 = Y.decode yamlBS :: Maybe (Y.YamlObject)
+ 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 = Y.decode yamlBS :: Maybe (Y.YamlObject)
+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"
+ let res = fromJust maybeRes
+ res @?= Sequence [Scalar (ys "foo"), Scalar (ys "baz"), Scalar (ys "foo"), Scalar (ys "boo"), Scalar (ys "buz"), Scalar (ys "boo")]
+ where yamlString = "- &anch foo\n- baz\n- *anch\n- &anch boo\n- buz\n- *anch"
+ yamlBS = B8.pack yamlString

0 comments on commit ef0fb29

Please sign in to comment.