yaml 0.4.1.2 → 0.5.0
raw patch · 7 files changed
+678/−316 lines, 7 filesdep +aesondep +conduitdep +containersdep −enumeratordep −test-frameworkdep −test-framework-hunitdep ~base
Dependencies added: aeson, conduit, containers, hspec, text, unordered-containers, vector, yaml
Dependencies removed: enumerator, test-framework, test-framework-hunit
Dependency ranges changed: base
Files
- Data/Yaml.hs +243/−0
- Text/Libyaml.hs +110/−97
- c/helper.c +1/−1
- runtests.hs +0/−176
- test/largest-string.yaml +6/−0
- test/main.hs +289/−0
- yaml.cabal +29/−42
+ Data/Yaml.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.Yaml+ ( -- * Types+ Value (..)+ , Parser+ -- * Constructors and accessors+ , object+ , array+ , (.=)+ , (.:)+ , (.:?)+ , (.!=)+ -- * Parsing+ , parseMonad+ , parseEither+ , parseMaybe+ -- * Classes+ , ToJSON (..)+ , FromJSON (..)+ -- * Encoding/decoding+ , encode+ , encodeFile+ , decode+ , decodeFile+ ) where++import qualified Text.Libyaml as Y+import Data.Aeson+ ( Value (..), ToJSON (..), FromJSON (..), object+ , (.=) , (.:) , (.:?) , (.!=)+ )+import Data.Aeson.Types (Pair, parseMaybe, parseEither, Parser)+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import qualified Data.Map as Map+import System.IO.Unsafe (unsafePerformIO)+import Control.Exception (try, throwIO, fromException, Exception)+import Control.Monad.Trans.State+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad (liftM)+import qualified Data.Vector as V+import Data.Text (Text, pack)+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.HashMap.Strict as M+import Data.Typeable++encode :: ToJSON a => a -> ByteString+encode obj = unsafePerformIO $+ C.runResourceT $ CL.sourceList (objToEvents $ toJSON obj)+ C.$$ Y.encode++encodeFile :: ToJSON a => FilePath -> a -> IO ()+encodeFile fp obj = C.runResourceT+ $ CL.sourceList (objToEvents $ toJSON obj)+ C.$$ Y.encodeFile fp++objToEvents :: Value -> [Y.Event]+objToEvents o = (:) EventStreamStart+ . (:) EventDocumentStart+ $ objToEvents' o+ [ EventDocumentEnd+ , EventStreamEnd+ ]++{- FIXME+scalarToEvent :: YamlScalar -> Event+scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing+-}++objToEvents' :: Value -> [Y.Event] -> [Y.Event]+--objToEvents' (Scalar s) rest = scalarToEvent s : rest+objToEvents' (Array list) rest =+ EventSequenceStart Nothing+ : foldr ($) (EventSequenceEnd : rest) (map objToEvents' $ V.toList list)+objToEvents' (Object pairs) rest =+ EventMappingStart Nothing+ : foldr ($) (EventMappingEnd : rest) (map pairToEvents $ M.toList pairs)+objToEvents' (String s) rest = EventScalar (encodeUtf8 s) NoTag Any Nothing : rest+objToEvents' Null rest = EventScalar "null" NoTag Literal Nothing : rest+objToEvents' (Bool True) rest = EventScalar "true" NoTag Literal Nothing : rest+objToEvents' (Bool False) rest = EventScalar "false" NoTag Literal Nothing : rest+objToEvents' (Number n) rest = EventScalar (S8.pack $ show n) NoTag Literal Nothing : rest++pairToEvents :: Pair -> [Y.Event] -> [Y.Event]+pairToEvents (k, v) rest =+ EventScalar (encodeUtf8 k) NoTag Any Nothing+ : objToEvents' v rest++-- Parsing++data ParseException = NonScalarKey+ | UnknownAlias { _anchorName :: Y.AnchorName }+ | UnexpectedEvent { _received :: Maybe Event+ , _expected :: Maybe Event+ }+ | InvalidYaml (Maybe String)+ deriving (Show, Typeable)+instance Exception ParseException++newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }+instance Monad m => Monad (PErrorT m) where+ return = PErrorT . return . Right+ (PErrorT m) >>= f = PErrorT $ do+ e <- m+ case e of+ Left e' -> return $ Left e'+ Right a -> runPErrorT $ f a+instance MonadTrans PErrorT where+ lift = PErrorT . liftM Right+instance MonadIO m => MonadIO (PErrorT m) where+ liftIO = lift . liftIO++type Parse = StateT (Map.Map String Value) IO++requireEvent :: Event -> C.Sink Event Parse ()+requireEvent e = do+ f <- CL.head+ if f == Just e+ then return ()+ else liftIO $ throwIO $ UnexpectedEvent f $ Just e++parse :: C.Sink Event Parse Value+parse = do+ requireEvent EventStreamStart+ requireEvent EventDocumentStart+ res <- parseO+ requireEvent EventDocumentEnd+ requireEvent EventStreamEnd+ return res++parseScalar :: ByteString -> Anchor+ -> C.Sink Event Parse Text+parseScalar v a = do+ let res = decodeUtf8With lenientDecode v+ case a of+ Nothing -> return res+ Just an -> do+ lift $ modify (Map.insert an $ String res)+ return res++parseO :: C.Sink Event Parse Value+parseO = do+ me <- CL.head+ case me of+ Just (EventScalar v _t _s a) -> fmap String $ parseScalar v a+ Just (EventSequenceStart a) -> parseS a id+ Just (EventMappingStart a) -> parseM a M.empty+ Just (EventAlias an) -> do+ m <- lift get+ case Map.lookup an m of+ Nothing -> liftIO $ throwIO $ UnknownAlias an+ Just v -> return v+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing++parseS :: Y.Anchor+ -> ([Value] -> [Value])+ -> C.Sink Event Parse Value+parseS a front = do+ me <- CL.peek+ case me of+ Just EventSequenceEnd -> do+ CL.drop 1+ let res = Array $ V.fromList $ front []+ case a of+ Nothing -> return res+ Just an -> do+ lift $ modify $ Map.insert an res+ return res+ _ -> do+ o <- parseO+ parseS a $ front . (:) o++parseM :: Y.Anchor+ -> M.HashMap Text Value+ -> C.Sink Event Parse Value+parseM a front = do+ me <- CL.peek+ case me of+ Just EventMappingEnd -> do+ CL.drop 1+ let res = Object front+ case a of+ Nothing -> return res+ Just an -> do+ lift $ modify $ Map.insert an res+ return res+ _ -> do+ CL.drop 1+ s <- case me of+ Just (EventScalar v _ _ a') -> parseScalar v a'+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing+ o <- parseO++ let al = M.insert s o front+ al' = if s == pack "<<"+ then case o of+ Object l -> M.union al l+ Array l -> M.union al $ foldl merge' M.empty $ V.toList l+ _ -> al+ else al+ parseM a $ M.insert s o al'+ where merge' al (Object om) = M.union al om+ merge' al _ = al++decode :: FromJSON a+ => ByteString+ -> Maybe a+decode bs = unsafePerformIO $ fmap (either (const Nothing) id) $ decodeHelper (Y.decode bs)++decodeFile :: FromJSON a+ => FilePath+ -> IO (Maybe a)+decodeFile fp = decodeHelper (Y.decodeFile fp) >>= either throwIO return++decodeHelper :: FromJSON a+ => C.Source Parse Y.Event+ -> IO (Either ParseException (Maybe a))+decodeHelper src = do+ x <- try $ flip evalStateT Map.empty $ C.runResourceT $ src C.$$ parse+ case x of+ Left e+ | Just pe <- fromException e -> return $ Left pe+ | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just $ show (ye :: YamlException)+ | otherwise -> throwIO e+ Right y -> return $ Right $ parseMaybe parseJSON y++array :: [Value] -> Value+array = Array . V.fromList++parseMonad :: Monad m => (a -> Parser b) -> a -> m b+parseMonad p = either fail return . parseEither p
Text/Libyaml.hs view
@@ -9,6 +9,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} +-- | Low-level, streaming YAML interface. For a higher-level interface, see+-- "Data.Yaml". module Text.Libyaml ( -- * The event stream Event (..)@@ -41,8 +43,9 @@ import Control.Monad.Trans.Class (lift) import Control.Exception (throwIO, Exception, finally)-import Data.Enumerator import Control.Applicative+import Control.Monad.Trans.Resource+import qualified Data.Conduit as C data Event = EventStreamStart@@ -120,8 +123,8 @@ foreign import ccall unsafe "yaml_parser_initialize" c_yaml_parser_initialize :: Parser -> IO CInt -foreign import ccall unsafe "&yaml_parser_delete"- c_yaml_parser_delete :: FunPtr (Parser -> IO ())+foreign import ccall unsafe "yaml_parser_delete"+ c_yaml_parser_delete :: Parser -> IO () foreign import ccall unsafe "yaml_parser_set_input_string" c_yaml_parser_set_input_string :: Parser@@ -146,8 +149,8 @@ c_fclose :: File -> IO () -foreign import ccall unsafe "&fclose_helper"- c_fclose_helper :: FunPtr (File -> Parser -> IO ())+foreign import ccall unsafe "fclose_helper"+ c_fclose_helper :: File -> IO () withForeignPtr' :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b withForeignPtr' fp f = do@@ -455,60 +458,67 @@ deriving (Show, Typeable) instance Exception ToEventRawException -decode :: MonadIO m => B.ByteString -> Enumerator Event m a-decode bs i = do- fp <- liftIO $ mallocForeignPtrBytes parserSize- res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize- liftIO $ addForeignPtrFinalizer c_yaml_parser_delete fp- a <-- if (res == 0)- then throwError $ YamlException "Yaml out of memory"- else do -- NOTE: can't replace the following with unsafeUseAsCString- -- since it must run in a MonadIO- let (fptr, offset, len) = B.toForeignPtr bs- withForeignPtr' fptr $ \ptr -> do- let ptr' = castPtr ptr `plusPtr` offset- len' = fromIntegral len- liftIO $ withForeignPtr fp $ \p ->- c_yaml_parser_set_input_string p ptr' len'- runParser fp i- return a+decode :: ResourceIO m => B.ByteString -> C.Source m Event+decode bs =+ C.sourceIO alloc cleanup (runParser . fst)+ where+ alloc = mask_ $ do+ ptr <- mallocBytes parserSize+ res <- c_yaml_parser_initialize ptr+ if res == 0+ then do+ c_yaml_parser_delete ptr+ free ptr+ throwIO $ YamlException "Yaml out of memory"+ else do+ let (bsfptr, offset, len) = B.toForeignPtr bs+ let bsptrOrig = unsafeForeignPtrToPtr bsfptr+ let bsptr = castPtr bsptrOrig `plusPtr` offset+ c_yaml_parser_set_input_string ptr bsptr (fromIntegral len)+ return (ptr, bsfptr)+ cleanup (ptr, bsfptr) = do+ touchForeignPtr bsfptr+ c_yaml_parser_delete ptr+ free ptr -decodeFile :: MonadIO m => FilePath -> Enumerator Event m a-decodeFile file i = do- fp <- liftIO $ mallocForeignPtrBytes parserSize- liftIO $ addForeignPtrFinalizer c_yaml_parser_delete fp- res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize- a <-- if res == 0- then throwError $ YamlException "Yaml out of memory"- else do- file' <- liftIO- $ withCString file $ \file' -> withCString "r" $ \r' ->- c_fopen file' r'- liftIO $ addForeignPtrFinalizerEnv c_fclose_helper file' fp- if (file' == nullPtr)- then throwError $ YamlException- $ "Yaml file not found: " ++ file- else do- liftIO $ withForeignPtr fp $ \p ->- c_yaml_parser_set_input_file p file'- a <- runParser fp i- return a- return a+decodeFile :: ResourceIO m => FilePath -> C.Source m Event+decodeFile file =+ C.sourceIO alloc cleanup (runParser . fst)+ where+ alloc = mask_ $ do+ ptr <- mallocBytes parserSize+ res <- c_yaml_parser_initialize ptr+ if res == 0+ then do+ c_yaml_parser_delete ptr+ free ptr+ throwIO $ YamlException "Yaml out of memory"+ else do+ file' <- liftIO+ $ withCString file $ \file' -> withCString "r" $ \r' ->+ c_fopen file' r'+ if file' == nullPtr+ then do+ c_fclose_helper file'+ c_yaml_parser_delete ptr+ free ptr+ throwIO $ YamlException+ $ "Yaml file not found: " ++ file+ else do+ c_yaml_parser_set_input_file ptr file'+ return (ptr, file')+ cleanup (ptr, file') = do+ c_fclose_helper file'+ c_yaml_parser_delete ptr+ free ptr -runParser :: MonadIO m- => ForeignPtr ParserStruct- -> Enumerator Event m a-runParser fp (Continue k) = do- e <- liftIO $ withForeignPtr fp parserParseOne'+runParser :: ResourceIO m => Parser -> m (C.SourceResult Event)+runParser parser = liftIO $ do+ e <- parserParseOne' parser case e of- Left err -> throwError $ YamlException err- Right Nothing -> continue k- Right (Just ev) -> do- step' <- lift $ runIteratee $ k $ Chunks [ev]- runParser fp step'-runParser _ step = returnI step+ Left err -> throwIO $ YamlException err+ Right Nothing -> return $ C.Closed+ Right (Just ev) -> return $ C.Open ev parserParseOne' :: Parser -> IO (Either String (Maybe Event))@@ -529,57 +539,60 @@ , show offset , "\n" ]- else liftIO $ Right <$> getEvent er+ else Right <$> getEvent er -encode :: MonadIO m => Iteratee Event m B.ByteString-encode = do- fp <- liftIO $ mallocForeignPtrBytes emitterSize- res <- liftIO $ withForeignPtr fp c_yaml_emitter_initialize- when (res == 0) $ throwError- $ YamlException "c_yaml_emitter_initialize failed"- buf <- liftIO $ mallocForeignPtrBytes bufferSize- liftIO $ withForeignPtr buf c_buffer_init- liftIO $ withForeignPtr fp $- \emitter -> withForeignPtr buf $- \b -> c_my_emitter_set_output emitter b- runEmitter (go buf) fp+encode :: ResourceIO m => C.Sink Event m ByteString+encode =+ runEmitter alloc close where- go buf = withForeignPtr buf $ \b -> do+ alloc emitter = do+ fbuf <- mallocForeignPtrBytes bufferSize+ withForeignPtr fbuf c_buffer_init+ withForeignPtr fbuf $ c_my_emitter_set_output emitter+ return fbuf+ close fbuf = withForeignPtr fbuf $ \b -> do ptr' <- c_get_buffer_buff b len <- c_get_buffer_used b fptr <- newForeignPtr_ $ castPtr ptr' return $ B.fromForeignPtr fptr 0 $ fromIntegral len -encodeFile :: MonadIO m+encodeFile :: ResourceIO m => FilePath- -> Iteratee Event m ()-encodeFile filePath = do- fp <- liftIO $ mallocForeignPtrBytes emitterSize- res <- liftIO $ withForeignPtr fp c_yaml_emitter_initialize- when (res == 0) $ throwError- $ YamlException "c_yaml_emitter_initialize failed"- file <- liftIO $ withCString filePath $- \filePath' -> withCString "w" $- \w' -> c_fopen filePath' w'- when (file == nullPtr) $ throwError- $ YamlException $ "could not open file for write: " ++ filePath- liftIO $ withForeignPtr fp $ flip c_yaml_emitter_set_output_file file- runEmitter (c_fclose file) fp+ -> C.Sink Event m ()+encodeFile filePath = C.Sink $ do+ (releaseKey, file) <- flip withIO c_fclose $ do+ file <- liftIO $ withCString filePath $+ \filePath' -> withCString "w" $+ \w' -> c_fopen filePath' w'+ if (file == nullPtr)+ then throwIO $ YamlException $ "could not open file for write: " ++ filePath+ else return file+ C.prepareSink $ runEmitter (alloc file) (return) -- FIXME close file early+ where+ alloc file emitter = do+ c_yaml_emitter_set_output_file emitter file+ return () -runEmitter :: MonadIO m- => IO a- -> ForeignPtr EmitterStruct- -> Iteratee Event m a-runEmitter close fp = continue go+runEmitter :: ResourceIO m+ => (Emitter -> IO a) -- ^ alloc+ -> (a -> IO b) -- ^ close+ -> C.Sink Event m b+runEmitter allocI closeI =+ C.sinkIO alloc cleanup push close where- go EOF = do- liftIO $ withForeignPtr fp c_yaml_emitter_delete- a <- liftIO close- yield a EOF- go (Chunks c) = do- liftIO $ withForeignPtr fp $ \emitter ->- mapM_ (\e -> toEventRaw e $ c_yaml_emitter_emit emitter) c- continue go+ alloc = mask_ $ do+ emitter <- mallocBytes emitterSize+ res <- c_yaml_emitter_initialize emitter+ when (res == 0) $ throwIO $ YamlException "c_yaml_emitter_initialize failed"+ a <- allocI emitter+ return (emitter, a)+ cleanup (emitter, _) = do+ c_yaml_emitter_delete emitter+ free emitter+ push (emitter, _) e = do+ liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter+ return C.Processing+ close (_, a) = liftIO $ closeI a data YamlException = YamlException String deriving (Show, Typeable)
c/helper.c view
@@ -135,7 +135,7 @@ yaml_parser_set_input_file(parser, in); } -int fclose_helper(FILE *file, yaml_parser_t *parser)+int fclose_helper(FILE *file) { if (! file) return 0; return fclose(file);
− runtests.hs
@@ -1,176 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-}-import Test.Framework (defaultMain)--import Text.Libyaml-import qualified Data.ByteString.Char8 as B8--import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test, path)--import qualified Data.Enumerator as E-import Data.Enumerator (($$))-import Data.List (foldl')--import System.Directory-import Control.Monad--main :: IO ()-main = defaultMain- [ testCase "count scalars with anchor" caseCountScalarsWithAnchor- , testCase "count sequences with anchor" caseCountSequencesWithAnchor- , testCase "count mappings with anchor" caseCountMappingsWithAnchor- , testCase "count aliases" caseCountAliases- , testCase "count scalars" caseCountScalars- , testCase "largest string" caseLargestString- , testCase "encode/decode" caseEncodeDecode- , testCase "encode/decode file" caseEncodeDecodeFile- , testCase "interleaved encode/decode" caseInterleave- , testCase "decode invalid document (without segfault)" caseDecodeInvalidDocument- ]--counter :: (Event -> Bool) -> Int -> E.Step Event IO Int-counter pred' acc =- E.Continue go- where- go E.EOF = E.yield acc E.EOF- go (E.Chunks c) = E.returnI $ counter pred' $ length (filter pred' c) + acc--caseHelper :: String- -> (Event -> Bool)- -> Int- -> Assertion-caseHelper yamlString pred' expRes = do- Right res <- E.run $ decode (B8.pack yamlString) (counter pred' 0)- res @?= expRes--caseCountScalarsWithAnchor :: Assertion-caseCountScalarsWithAnchor =- caseHelper yamlString isScalarA 1- where- yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"- isScalarA (EventScalar _ _ _ (Just _)) = True- isScalarA _ = False--caseCountSequencesWithAnchor :: Assertion-caseCountSequencesWithAnchor =- caseHelper yamlString isSequenceStartA 1- where- yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"- isSequenceStartA (EventSequenceStart (Just _)) = True- isSequenceStartA _ = False--caseCountMappingsWithAnchor :: Assertion-caseCountMappingsWithAnchor =- caseHelper yamlString isMappingA 1- where- yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"- isMappingA (EventMappingStart (Just _)) = True- isMappingA _ = False--caseCountAliases :: Assertion-caseCountAliases =- caseHelper yamlString isAlias 1- where- yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"- isAlias EventAlias{} = True- isAlias _ = False--caseCountScalars :: Assertion-caseCountScalars = do- Right res <- E.run $ decode yamlBS $ counter' accum- res @?= (7, 1, 2)- where- yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"- yamlBS = B8.pack yamlString- counter' acc = E.Continue $ \s ->- case s of- E.EOF -> E.yield acc E.EOF- E.Chunks c -> E.returnI $ counter' $ foldl' adder acc c- adder (s, l, m) (EventScalar{}) = (s + 1, l, m)- adder (s, l, m) (EventSequenceStart{}) = (s, l + 1, m)- adder (s, l, m) (EventMappingStart{}) = (s, l, m + 1)- adder a _ = a- accum = (0, 0, 0) :: (Int, Int, Int)--caseLargestString :: Assertion-caseLargestString = do- Right res <- E.run $ decodeFile filePath $ dec accum- res @?= (length expected, expected)- where- expected = "this one is just a little bit bigger than the others"- filePath = "test/largest-string.yaml"- dec acc = E.Continue $ \s ->- case s of- E.EOF -> E.yield acc E.EOF- E.Chunks c ->- let acc' = foldl' adder acc c- in E.returnI $ dec acc'- adder (i, s) (EventScalar bs _ _ _) =- let s' = B8.unpack bs- i' = length s'- in if i' > i then (i', s') else (i, s)- adder acc _ = acc- accum = (0, "no strings found")--newtype MyEvent = MyEvent Event deriving Show-instance Eq MyEvent where- (MyEvent (EventScalar s t _ _)) == (MyEvent (EventScalar s' t' _ _)) =- s == s' && t == t'- MyEvent e1 == MyEvent e2 = e1 == e2--caseEncodeDecode :: Assertion-caseEncodeDecode = do- Right eList <- E.run $ decode yamlBS $$ E.consume- Right bs <- E.run $ E.enumList 1 eList $$ encode- Right eList2 <- E.run $ decode bs $$ E.consume- map MyEvent eList @=? map MyEvent eList2- where- yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"- yamlBS = B8.pack yamlString--removeFile' :: FilePath -> IO ()-removeFile' fp = do- x <- doesFileExist fp- when x $ removeFile fp--caseEncodeDecodeFile :: Assertion-caseEncodeDecodeFile = do- removeFile' tmpPath- Right eList <- E.run $ decodeFile filePath $$ E.consume- E.run $ E.enumList 1 eList $$ encodeFile tmpPath- Right eList2 <- E.run $ decodeFile filePath $$ E.consume- map MyEvent eList @=? map MyEvent eList2- where- filePath = "test/largest-string.yaml"- tmpPath = "tmp.yaml"--caseInterleave :: Assertion-caseInterleave = do- removeFile' tmpPath- removeFile' tmpPath2- Right () <- E.run $ decodeFile filePath $$ encodeFile tmpPath- Right () <- E.run $ decodeFile tmpPath $$ encodeFile tmpPath2- f1 <- readFile tmpPath- f2 <- readFile tmpPath2- f1 @=? f2- where- filePath = "test/largest-string.yaml"- tmpPath = "tmp.yaml"- tmpPath2 = "tmp2.yaml"--caseDecodeInvalidDocument :: Assertion-caseDecodeInvalidDocument = do- x <- E.run $ decode yamlBS ignore- case x of- Left _ -> return ()- Right y -> do- putStrLn $ "bad return value: " ++ show y- assertFailure "expected parsing exception, but got no errors"- where- yamlString = " - foo\n - baz\nbuz"- yamlBS = B8.pack yamlString- ignore = E.Continue $ \s ->- case s of- E.EOF -> E.yield () E.EOF- E.Chunks _-> E.returnI ignore
+ test/largest-string.yaml view
@@ -0,0 +1,6 @@+this is a long string: but this one is even longer+this is shorter:+ - many+ - tiny+ - string+one the other hand: this one is just a little bit bigger than the others
+ test/main.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++import qualified Text.Libyaml as Y+import qualified Data.ByteString.Char8 as B8++import Test.HUnit hiding (Test, path)++import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL++import System.Directory+import Control.Monad+import Control.Exception (try, SomeException)+import Test.Hspec.Monadic+import Test.Hspec.HUnit ()++import qualified Data.Yaml as D+import Data.Yaml (object, array)+import Data.Maybe+import qualified Data.HashMap.Strict as M+import qualified Data.Text as T++main :: IO ()+main = hspecX $ do+ describe "streaming" $ do+ it "count scalars with anchor" caseCountScalarsWithAnchor+ it "count sequences with anchor" caseCountSequencesWithAnchor+ it "count mappings with anchor" caseCountMappingsWithAnchor+ it "count aliases" caseCountAliases+ it "count scalars" caseCountScalars+ it "largest string" caseLargestString+ it "encode/decode" caseEncodeDecode+ it "encode/decode file" caseEncodeDecodeFile+ it "interleaved encode/decode" caseInterleave+ it "decode invalid document (without segfault)" caseDecodeInvalidDocument+ describe "Data.Yaml" $ do+ it "encode/decode" caseEncodeDecodeData+ it "encode/decode file" caseEncodeDecodeFileData+ it "encode/decode strings" caseEncodeDecodeStrings+ it "decode invalid file" caseDecodeInvalid+ describe "Data.Yaml aliases" $ do+ it "simple scalar alias" caseSimpleScalarAlias+ it "simple sequence alias" caseSimpleSequenceAlias+ it "simple mapping alias" caseSimpleMappingAlias+ it "mapping alias before anchor" caseMappingAliasBeforeAnchor+ it "mapping alias inside anchor" caseMappingAliasInsideAnchor+ it "scalar alias overriding" caseScalarAliasOverriding+ describe "Data.Yaml merge keys" $ do+ it "test uniqueness of keys" caseAllKeysShouldBeUnique+ it "test mapping merge" caseSimpleMappingMerge+ it "test sequence of mappings merging" caseMergeSequence++counter :: (Y.Event -> Bool) -> C.Sink Y.Event IO Int+counter pred' =+ CL.fold (\cnt e -> (if pred' e then 1 else 0) + cnt) 0++caseHelper :: String+ -> (Y.Event -> Bool)+ -> Int+ -> Assertion+caseHelper yamlString pred' expRes = do+ res <- C.runResourceT $ Y.decode (B8.pack yamlString) C.$$ counter pred'+ res @?= expRes++caseCountScalarsWithAnchor :: Assertion+caseCountScalarsWithAnchor =+ caseHelper yamlString isScalarA 1+ where+ yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"+ isScalarA (Y.EventScalar _ _ _ (Just _)) = True+ isScalarA _ = False++caseCountSequencesWithAnchor :: Assertion+caseCountSequencesWithAnchor =+ caseHelper yamlString isSequenceStartA 1+ where+ yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"+ isSequenceStartA (Y.EventSequenceStart (Just _)) = True+ isSequenceStartA _ = False++caseCountMappingsWithAnchor :: Assertion+caseCountMappingsWithAnchor =+ caseHelper yamlString isMappingA 1+ where+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"+ isMappingA (Y.EventMappingStart (Just _)) = True+ isMappingA _ = False++caseCountAliases :: Assertion+caseCountAliases =+ caseHelper yamlString isAlias 1+ where+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"+ isAlias Y.EventAlias{} = True+ isAlias _ = False++caseCountScalars :: Assertion+caseCountScalars = do+ res <- C.runResourceT $ Y.decode yamlBS C.$$ CL.fold adder accum+ res @?= (7, 1, 2)+ where+ yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"+ yamlBS = B8.pack yamlString+ adder (s, l, m) (Y.EventScalar{}) = (s + 1, l, m)+ adder (s, l, m) (Y.EventSequenceStart{}) = (s, l + 1, m)+ adder (s, l, m) (Y.EventMappingStart{}) = (s, l, m + 1)+ adder a _ = a+ accum = (0, 0, 0) :: (Int, Int, Int)++caseLargestString :: Assertion+caseLargestString = do+ res <- C.runResourceT $ Y.decodeFile filePath C.$$ CL.fold adder accum+ res @?= (length expected, expected)+ where+ expected = "this one is just a little bit bigger than the others"+ filePath = "test/largest-string.yaml"+ adder (i, s) (Y.EventScalar bs _ _ _) =+ let s' = B8.unpack bs+ i' = length s'+ in if i' > i then (i', s') else (i, s)+ adder acc _ = acc+ accum = (0, "no strings found")++newtype MyEvent = MyEvent Y.Event deriving Show+instance Eq MyEvent where+ (MyEvent (Y.EventScalar s t _ _)) == (MyEvent (Y.EventScalar s' t' _ _)) =+ s == s' && t == t'+ MyEvent e1 == MyEvent e2 = e1 == e2++caseEncodeDecode :: Assertion+caseEncodeDecode = do+ eList <- C.runResourceT $ Y.decode yamlBS C.$$ CL.consume+ bs <- C.runResourceT $ CL.sourceList eList C.$$ Y.encode+ eList2 <- C.runResourceT $ Y.decode bs C.$$ CL.consume+ map MyEvent eList @=? map MyEvent eList2+ where+ yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"+ yamlBS = B8.pack yamlString++removeFile' :: FilePath -> IO ()+removeFile' fp = do+ x <- doesFileExist fp+ when x $ removeFile fp++caseEncodeDecodeFile :: Assertion+caseEncodeDecodeFile = do+ removeFile' tmpPath+ eList <- C.runResourceT $ Y.decodeFile filePath C.$$ CL.consume+ C.runResourceT $ CL.sourceList eList C.$$ Y.encodeFile tmpPath+ eList2 <- C.runResourceT $ Y.decodeFile filePath C.$$ CL.consume+ map MyEvent eList @=? map MyEvent eList2+ where+ filePath = "test/largest-string.yaml"+ tmpPath = "tmp.yaml"++caseInterleave :: Assertion+caseInterleave = do+ removeFile' tmpPath+ removeFile' tmpPath2+ () <- C.runResourceT $ Y.decodeFile filePath C.$$ Y.encodeFile tmpPath+ () <- C.runResourceT $ Y.decodeFile tmpPath C.$$ Y.encodeFile tmpPath2+ f1 <- readFile tmpPath+ f2 <- readFile tmpPath2+ f1 @=? f2+ where+ filePath = "test/largest-string.yaml"+ tmpPath = "tmp.yaml"+ tmpPath2 = "tmp2.yaml"++caseDecodeInvalidDocument :: Assertion+caseDecodeInvalidDocument = do+ x <- try $ C.runResourceT $ Y.decode yamlBS C.$$ CL.sinkNull+ case x of+ Left (_ :: SomeException) -> return ()+ Right y -> do+ putStrLn $ "bad return value: " ++ show y+ assertFailure "expected parsing exception, but got no errors"+ where+ yamlString = " - foo\n - baz\nbuz"+ yamlBS = B8.pack yamlString++mkScalar :: String -> D.Value+mkScalar = mkStrScalar++mkStrScalar :: String -> D.Value+mkStrScalar = D.String . T.pack++mappingKey :: D.Value-> String -> D.Value+mappingKey (D.Object m) k = (fromJust . M.lookup (T.pack k) $ m)+mappingKey _ _ = error "expected Object"++decodeYaml :: String -> Maybe D.Value+decodeYaml s = D.decode $ B8.pack s++sample :: D.Value+sample = array+ [ D.String "foo"+ , object+ [ ("bar1", D.String "bar2")+ ]+ ]++caseEncodeDecodeData :: Assertion+caseEncodeDecodeData = do+ let out = D.decode $ D.encode sample+ out @?= Just sample++caseEncodeDecodeFileData :: Assertion+caseEncodeDecodeFileData = do+ let fp = "tmp.yaml"+ D.encodeFile fp sample+ out <- D.decodeFile fp+ out @?= Just sample++caseEncodeDecodeStrings :: Assertion+caseEncodeDecodeStrings = do+ let out = D.decode $ D.encode sample+ out @?= Just sample++caseDecodeInvalid :: Assertion+caseDecodeInvalid = do+ let invalid = B8.pack "\tthis is 'not' valid :-)"+ Nothing @=? (D.decode invalid :: Maybe D.Value)++caseSimpleScalarAlias :: Assertion+caseSimpleScalarAlias = do+ let maybeRes = decodeYaml "- &anch foo\n- baz\n- *anch"+ isJust maybeRes @? "decoder should return Just YamlObject but returned Nothing"+ let res = fromJust maybeRes+ res @?= array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo")]++caseSimpleSequenceAlias :: Assertion+caseSimpleSequenceAlias = do+ 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 @?= object [("seq", array [(mkScalar "foo"), (mkScalar "baz")]), ("seq2", array [(mkScalar "foo"), (mkScalar "baz")])]++caseSimpleMappingAlias :: Assertion+caseSimpleMappingAlias = do+ 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 @?= object [(T.pack "map", object [("key1", mkScalar "foo"), ("key2", (mkScalar "baz"))]), (T.pack "map2", object [("key1", (mkScalar "foo")), ("key2", mkScalar "baz")])]++caseMappingAliasBeforeAnchor :: Assertion+caseMappingAliasBeforeAnchor = do+ let res = decodeYaml "map: *anch\nmap2: &anch\n key1: foo\n key2: baz"+ isNothing res @? "decode should return Nothing due to unknown alias"++caseMappingAliasInsideAnchor :: Assertion+caseMappingAliasInsideAnchor = do+ let res = decodeYaml "map: &anch\n key1: foo\n key2: *anch"+ isNothing res @? "decode should return Nothing due to unknown alias"++caseScalarAliasOverriding :: Assertion+caseScalarAliasOverriding = do+ 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 @?= array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo"), (mkScalar "boo"), (mkScalar "buz"), (mkScalar "boo")]++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" @?= (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" @?= (mkScalar "foo")+ mappingKey res "foo3" @?= (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" @?= (mkScalar "foo")+ mappingKey res "k1" @?= (mkStrScalar "1")+ mappingKey res "k2" @?= (mkStrScalar "2")+ mappingKey res "k3" @?= (mkStrScalar "4")
yaml.cabal view
@@ -1,5 +1,5 @@ name: yaml-version: 0.4.1.2+version: 0.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov @@ -12,35 +12,32 @@ don't need to worry about any non-Haskell dependencies. category: Web stability: unstable-cabal-version: >= 1.2+cabal-version: >= 1.8 build-type: Simple homepage: http://github.com/snoyberg/yaml/ extra-source-files: c/helper.h, libyaml/yaml_private.h, libyaml/yaml.h,- libyaml/LICENSE+ libyaml/LICENSE+ test/main.hs+ test/largest-string.yaml flag system-libyaml description: Use the system-wide libyaml instead of the bundled copy default: False -flag nolib- description: Skip building the library- default: False-flag buildtests- description: Build the executable to run unit tests- default: False- library- if flag(nolib)- Buildable: False- else- Buildable: True build-depends: base >= 4 && < 5 , transformers >= 0.1 && < 0.3 , bytestring >= 0.9.1.4 && < 0.10- , enumerator >= 0.4 && < 0.5+ , conduit >= 0.0 && < 0.1+ , aeson >= 0.5+ , containers+ , unordered-containers+ , vector+ , text exposed-modules: Text.Libyaml+ Data.Yaml ghc-options: -Wall c-sources: c/helper.c include-dirs: c@@ -57,33 +54,23 @@ libyaml/writer.c include-dirs: libyaml -executable runtests- if flag(buildtests)- Buildable: True- cpp-options: -DTEST- build-depends: test-framework- , test-framework-hunit- , HUnit- , directory- , base >= 4 && < 5- , transformers >= 0.1 && < 0.3- , bytestring >= 0.9.1.4 && < 0.10- , enumerator >= 0.4 && < 0.5- else- Buildable: False+test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: main.hs+ cpp-options: -DTEST+ build-depends: hspec+ , HUnit+ , directory+ , base >= 4 && < 5+ , transformers >= 0.1 && < 0.3+ , bytestring >= 0.9.1.4 && < 0.10+ , conduit+ , yaml+ , text+ , unordered-containers ghc-options: -Wall c-sources: c/helper.c include-dirs: c- if flag(system-libyaml)- pkgconfig-depends: yaml-0.1- else- c-sources: libyaml/api.c,- libyaml/dumper.c,- libyaml/emitter.c,- libyaml/loader.c,- libyaml/parser.c,- libyaml/reader.c,- libyaml/scanner.c,- libyaml/writer.c- include-dirs: libyaml- main-is: runtests.hs+ pkgconfig-depends: yaml-0.1+ extra-libraries: yaml