yaml 0.2.1 → 0.3.0
raw patch · 5 files changed
+444/−331 lines, 5 filesdep +ListLikedep +MonadCatchIO-transformersdep +directorydep −QuickCheckdep −control-monad-failuredep −test-framework-quickcheck2dep ~basedep ~transformers
Dependencies added: ListLike, MonadCatchIO-transformers, directory, iteratee
Dependencies removed: QuickCheck, control-monad-failure, test-framework-quickcheck2
Dependency ranges changed: base, transformers
Files
- Text/Libyaml.hs +266/−254
- c/helper.c +20/−0
- c/helper.h +7/−0
- runtests.hs +134/−54
- yaml.cabal +17/−23
Text/Libyaml.hs view
@@ -14,21 +14,9 @@ Event (..) , Style (..) , Tag (..)- -- * Exceptions- , YamlException (..)- -- * Enumerator- , With (..)- -- * Encoder- , YamlEncoder- , YamlDecoder- , parseEvent- , emitEvent- -- ** Combinators- , emitStream- , emitDocument- , emitSequence- , emitMapping- -- * Higher level functions+ , AnchorName+ , Anchor+ -- * Encoding and decoding , encode , decode , encodeFile@@ -38,35 +26,39 @@ import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString-import Data.ByteString (ByteString)+import qualified Data.ByteString.Unsafe as BU+import Data.ByteString (ByteString, packCStringLen) import Control.Monad import Foreign.C import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal.Alloc-#if TRANSFORMERS_02+import Data.Data++#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class #else import "transformers" Control.Monad.Trans #endif-import Control.Monad.Failure.Transformers-import qualified Control.Monad.Trans.Error as ErrorT-import Control.Monad.Trans.Reader -import Control.Exception (throwIO, Exception, SomeException)-import Data.Typeable (Typeable)+import Control.Exception (throwIO, Exception)+import Data.Iteratee+import qualified Data.Iteratee.Base.StreamChunk as SC+import Control.Applicative+import Control.Monad.CatchIO (MonadCatchIO, finally) +import qualified Data.ListLike as LL+ data Event =- EventNone- | EventStreamStart+ EventStreamStart | EventStreamEnd | EventDocumentStart | EventDocumentEnd- | EventAlias- | EventScalar !ByteString !Tag !Style- | EventSequenceStart+ | EventAlias !AnchorName+ | EventScalar !ByteString !Tag !Style !Anchor+ | EventSequenceStart !Anchor | EventSequenceEnd- | EventMappingStart+ | EventMappingStart !Anchor | EventMappingEnd deriving (Show, Eq) @@ -76,7 +68,7 @@ | DoubleQuoted | Literal | Folded- deriving (Show, Eq, Enum, Bounded, Ord)+ deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable) data Tag = StrTag | FloatTag@@ -88,8 +80,11 @@ | MapTag | UriTag String | NoTag- deriving (Show, Eq)+ deriving (Show, Eq, Read, Data, Typeable) +type AnchorName = String+type Anchor = Maybe AnchorName+ tagToString :: Tag -> String tagToString StrTag = "tag:yaml.org,2002:str" tagToString FloatTag = "tag:yaml.org,2002:float"@@ -117,30 +112,6 @@ stringToTag "" = NoTag stringToTag s = UriTag s -data YamlException =- YamlParserException- { parserProblem :: String- , parserContext :: String- , parserOffset :: Int- }- | YamlEmitterException- { emitterEvent :: Event- , emitterProblem :: String- }- | YamlOutOfMemory- | YamlInvalidEventStreamBeginning [Event]- | YamlInvalidEventStreamEnd [Event]- | YamlPrematureEventStreamEnd- | YamlNonScalarKey- | YamlInvalidStartingEvent Event- | YamlFileNotFound FilePath- | YamlOtherException SomeException- | YamlStringException String- deriving (Show, Typeable)-instance Exception YamlException-instance ErrorT.Error YamlException where- strMsg = YamlStringException- data ParserStruct type Parser = Ptr ParserStruct parserSize :: Int@@ -180,58 +151,11 @@ c_fclose :: File -> IO () -class MonadIO m => With m where- with :: (forall b'. (a -> IO b') -> IO b') -> (a -> m b) -> m b--instance With IO where- with = id-instance With m => With (ReaderT r m) where- with orig f = ReaderT $ \r -> do- let f' a = (runReaderT $ f a) r- with orig f'-instance (ErrorT.Error e, With m) => With (ErrorT.ErrorT e m) where- with orig f = ErrorT.ErrorT $ with orig $ ErrorT.runErrorT . f--allocaBytesR :: With m => Int -> (Ptr a -> m b) -> m b-allocaBytesR i = with (allocaBytes i)--withCStringR :: With m => String -> (Ptr CChar -> m a) -> m a-withCStringR s = with (withCString s)--withFileParser :: (MonadFailure YamlException m, With m)- => FilePath- -> (Parser -> m a)- -> m a-withFileParser fp f = allocaBytesR parserSize $ \p -> do- res <- liftIO $ c_yaml_parser_initialize p- when (res == 0) $ failure YamlOutOfMemory- file <- withCStringR fp $ \fp' -> withCStringR "r" $ \r' ->- liftIO (c_fopen fp' r')- when (file == nullPtr) $ failure $ YamlFileNotFound fp- liftIO $ c_yaml_parser_set_input_file p file- ret <- f p- liftIO $ c_fclose file- liftIO $ c_yaml_parser_delete p -- could use some finallys here- return ret--withParser :: (MonadFailure YamlException m, With m)- => B.ByteString- -> (Parser -> m a)- -> m a-withParser bs f = allocaBytesR parserSize $ \p -> do- res <- liftIO $ c_yaml_parser_initialize p- when (res == 0) $ failure YamlOutOfMemory- let (fptr, offset, len) = B.toForeignPtr bs- ret <- withForeignPtrR fptr $ \ptr -> do- let ptr' = castPtr ptr `plusPtr` offset- len' = fromIntegral len- liftIO $ c_yaml_parser_set_input_string p ptr' len'- f p- liftIO $ c_yaml_parser_delete p -- FIXME use finally- return ret--withForeignPtrR :: With m => ForeignPtr a -> (Ptr a -> m b) -> m b-withForeignPtrR fp = with (withForeignPtr fp)+withForeignPtr' :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b+withForeignPtr' fp f = do+ r <- f $ unsafeForeignPtrToPtr fp+ liftIO $ touchForeignPtr fp+ return r foreign import ccall unsafe "yaml_parser_parse" c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt@@ -251,24 +175,9 @@ makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String makeString f a = do cchar <- castPtr `liftM` f a- liftIO $ peekCString cchar--parserParseOne :: (MonadFailure YamlException m, With m)- => Parser- -> m Event-parserParseOne parser = allocaBytesR eventSize $ \er -> do- res <- liftIO $ c_yaml_parser_parse parser er- event <-- if res == 0- then do- problem <- liftIO $ makeString c_get_parser_error_problem parser- context <- liftIO $ makeString c_get_parser_error_context parser- offset <- liftIO $ fromIntegral `fmap`- c_get_parser_error_offset parser- failure $ YamlParserException problem context offset- else liftIO $ getEvent er- liftIO $ c_yaml_event_delete er -- FIXME use finally- return event+ if cchar == nullPtr+ then return ""+ else liftIO $ peekCString cchar data EventType = YamlNoEvent | YamlStreamStartEvent@@ -301,16 +210,33 @@ foreign import ccall unsafe "get_scalar_style" c_get_scalar_style :: EventRaw -> IO CInt -getEvent :: EventRaw -> IO Event+foreign import ccall unsafe "get_scalar_anchor"+ c_get_scalar_anchor :: EventRaw -> IO CString++foreign import ccall unsafe "get_sequence_start_anchor"+ c_get_sequence_start_anchor :: EventRaw -> IO CString++foreign import ccall unsafe "get_mapping_start_anchor"+ c_get_mapping_start_anchor :: EventRaw -> IO CString++foreign import ccall unsafe "get_alias_anchor"+ c_get_alias_anchor :: EventRaw -> IO CString++getEvent :: EventRaw -> IO (Maybe Event) getEvent er = do et <- c_get_event_type er case toEnum $ fromEnum et of- YamlNoEvent -> return EventNone- YamlStreamStartEvent -> return EventStreamStart- YamlStreamEndEvent -> return EventStreamEnd- YamlDocumentStartEvent -> return EventDocumentStart- YamlDocumentEndEvent -> return EventDocumentEnd- YamlAliasEvent -> return EventAlias+ YamlNoEvent -> return Nothing+ YamlStreamStartEvent -> return $ Just EventStreamStart+ YamlStreamEndEvent -> return $ Just EventStreamEnd+ YamlDocumentStartEvent -> return $ Just EventDocumentStart+ YamlDocumentEndEvent -> return $ Just EventDocumentEnd+ YamlAliasEvent -> do+ yanchor <- c_get_alias_anchor er+ anchor <- if yanchor == nullPtr+ then error "got YamlAliasEvent with empty anchor"+ else peekCString yanchor+ return $ Just $ EventAlias anchor YamlScalarEvent -> do yvalue <- c_get_scalar_value er ylen <- c_get_scalar_length er@@ -321,19 +247,31 @@ let yvalue' = castPtr yvalue let ytag' = castPtr ytag let ylen' = fromEnum ylen- let ylen'' = toEnum $ fromEnum ylen- bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''+ bs <- packCStringLen (yvalue', ylen') tagbs <- if ytag_len' == 0 then return Data.ByteString.empty- else B.create ytag_len'- $ \dest -> B.memcpy dest ytag' (toEnum ytag_len')+ else packCStringLen (ytag', ytag_len') let style = toEnum $ fromEnum ystyle- return $ EventScalar bs (bsToTag tagbs) style- YamlSequenceStartEvent -> return EventSequenceStart- YamlSequenceEndEvent -> return EventSequenceEnd- YamlMappingStartEvent -> return EventMappingStart- YamlMappingEndEvent -> return EventMappingEnd+ yanchor <- c_get_scalar_anchor er+ anchor <- if yanchor == nullPtr+ then return Nothing+ else fmap Just $ peekCString yanchor+ return $ Just $ EventScalar bs (bsToTag tagbs) style anchor+ YamlSequenceStartEvent -> do+ yanchor <- c_get_sequence_start_anchor er+ anchor <- if yanchor == nullPtr+ then return Nothing+ else fmap Just $ peekCString yanchor+ return $ Just $ EventSequenceStart anchor+ YamlSequenceEndEvent -> return $ Just EventSequenceEnd+ YamlMappingStartEvent -> do+ yanchor <- c_get_mapping_start_anchor er+ anchor <- if yanchor == nullPtr+ then return Nothing+ else fmap Just $ peekCString yanchor+ return $ Just $ EventMappingStart anchor+ YamlMappingEndEvent -> return $ Just EventMappingEnd -- Emitter @@ -362,90 +300,15 @@ foreign import ccall unsafe "get_buffer_used" c_get_buffer_used :: Buffer -> IO CULong -withBufferR :: (With m, MonadFailure YamlException m)- => (Buffer -> m ())- -> m B.ByteString-withBufferR f = allocaBytesR bufferSize $ \b -> do- liftIO $ c_buffer_init b- f b- ptr' <- liftIO $ c_get_buffer_buff b- len <- liftIO $ c_get_buffer_used b- fptr <- liftIO $ newForeignPtr_ $ castPtr ptr'- return $ B.fromForeignPtr fptr 0 $ fromIntegral len- foreign import ccall unsafe "my_emitter_set_output" c_my_emitter_set_output :: Emitter -> Buffer -> IO () -withEmitter :: (With m, MonadFailure YamlException m)- => (Emitter -> m ())- -> m B.ByteString-withEmitter f = allocaBytesR emitterSize $ \e -> do- res <- liftIO $ c_yaml_emitter_initialize e- when (res == 0) $ failure YamlOutOfMemory- bs <- withBufferR $ \b -> do- liftIO $ c_my_emitter_set_output e b- f e- liftIO $ c_yaml_emitter_delete e -- FIXME finally- return bs- foreign import ccall unsafe "yaml_emitter_set_output_file" c_yaml_emitter_set_output_file :: Emitter -> File -> IO () -withEmitterFile :: (With m, MonadFailure YamlException m)- => FilePath- -> (Emitter -> m ())- -> m ()-withEmitterFile fp f = allocaBytesR emitterSize $ \e -> do- res <- liftIO $ c_yaml_emitter_initialize e- when (res == 0) $ failure YamlOutOfMemory- file <- withCStringR fp $ \fp' -> withCStringR "w" $ \w' ->- liftIO (c_fopen fp' w')- res' <-- if file == nullPtr- then failure $ YamlFileNotFound fp- else do- liftIO $ c_yaml_emitter_set_output_file e file- res' <- f e- liftIO $ c_yaml_emitter_delete e- return res'- liftIO $ c_fclose file -- FIXME use finally- return res'- foreign import ccall unsafe "yaml_emitter_emit" c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt -foreign import ccall unsafe "get_emitter_error"- c_get_emitter_error :: Emitter -> IO (Ptr CUChar)--emitEvent :: (MonadIO m, MonadFailure YamlException m)- => Event- -> YamlEncoder m ()-emitEvent e = do- emitter <- ask- res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter- when (res == 0) $ do- problem <- liftIO $ makeString c_get_emitter_error emitter- failure $ YamlEmitterException e problem--emitStream, emitDocument, emitSequence, emitMapping- :: (MonadIO m, MonadFailure YamlException m)- => YamlEncoder m ()- -> YamlEncoder m ()-emitStream e = emitEvent EventStreamStart >> e >> emitEvent EventStreamEnd-emitDocument e = emitEvent EventDocumentStart >> e- >> emitEvent EventDocumentEnd-emitSequence e = emitEvent EventSequenceStart >> e- >> emitEvent EventSequenceEnd-emitMapping e = emitEvent EventMappingStart >> e- >> emitEvent EventMappingEnd--parseEvent :: (With m, MonadFailure YamlException m)- => YamlDecoder m Event-parseEvent = ask >>= parserParseOne--type YamlDecoder = ReaderT Parser-type YamlEncoder = ReaderT Emitter- foreign import ccall unsafe "yaml_stream_start_event_initialize" c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt @@ -494,8 +357,14 @@ foreign import ccall unsafe "yaml_mapping_end_event_initialize" c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt +foreign import ccall unsafe "yaml_alias_event_initialize"+ c_yaml_alias_event_initialize+ :: EventRaw+ -> Ptr CUChar+ -> IO CInt+ toEventRaw :: Event -> (EventRaw -> IO a) -> IO a-toEventRaw e f = allocaBytesR eventSize $ \er -> do+toEventRaw e f = allocaBytes eventSize $ \er -> do ret <- case e of EventStreamStart -> c_yaml_stream_start_event_initialize@@ -507,48 +376,80 @@ c_simple_document_start er EventDocumentEnd -> c_yaml_document_end_event_initialize er 1- EventScalar bs thetag style -> do- let (fvalue, offset, len) = B.toForeignPtr bs- withForeignPtr fvalue $ \value -> do- let value' = value `plusPtr` offset- len' = fromIntegral len- value'' = if ptrToIntPtr value' == 0- then intPtrToPtr 1 -- c/api.c:827- else value'+ EventScalar bs thetag style anchor -> do+ BU.unsafeUseAsCStringLen bs $ \(value, len) -> do+ let value' = castPtr value :: Ptr CUChar+ len' = fromIntegral len :: CInt let thetag' = tagToString thetag withCString thetag' $ \tag' -> do let style' = toEnum $ fromEnum style tagP = castPtr tag' qi = if null thetag' then 1 else 0- c_yaml_scalar_event_initialize- er- nullPtr -- anchor- tagP -- tag- value'' -- value- len' -- length- 0 -- plain_implicit- qi -- quoted_implicit- style' -- style- EventSequenceStart ->+ case anchor of+ Nothing ->+ c_yaml_scalar_event_initialize+ er+ nullPtr -- anchor+ tagP -- tag+ value' -- value+ len' -- length+ 0 -- plain_implicit+ qi -- quoted_implicit+ style' -- style+ Just anchor' ->+ withCString anchor' $ \anchorP' -> do+ let anchorP = castPtr anchorP'+ c_yaml_scalar_event_initialize+ er+ anchorP -- anchor+ tagP -- tag+ value' -- value+ len' -- length+ 0 -- plain_implicit+ qi -- quoted_implicit+ style' -- style+ EventSequenceStart Nothing -> c_yaml_sequence_start_event_initialize er nullPtr nullPtr 1 0 -- YAML_ANY_SEQUENCE_STYLE+ EventSequenceStart (Just anchor) ->+ withCString anchor $ \anchor' -> do+ let anchorP = castPtr anchor'+ c_yaml_sequence_start_event_initialize+ er+ anchorP+ nullPtr+ 1+ 0 -- YAML_ANY_SEQUENCE_STYLE EventSequenceEnd -> c_yaml_sequence_end_event_initialize er- EventMappingStart ->+ EventMappingStart Nothing -> c_yaml_mapping_start_event_initialize er nullPtr nullPtr 1 0 -- YAML_ANY_SEQUENCE_STYLE+ EventMappingStart (Just anchor) ->+ withCString anchor $ \anchor' -> do+ let anchorP = castPtr anchor'+ c_yaml_mapping_start_event_initialize+ er+ anchorP+ nullPtr+ 1+ 0 -- YAML_ANY_SEQUENCE_STYLE EventMappingEnd -> c_yaml_mapping_end_event_initialize er- EventAlias -> error "toEventRaw: EventAlias not supported"- EventNone -> error "toEventRaw: EventNone not supported"+ EventAlias anchor ->+ withCString anchor $ \anchorP' -> do+ let anchorP = castPtr anchorP'+ c_yaml_alias_event_initialize+ er+ anchorP unless (ret == 1) $ throwIO $ ToEventRawException ret f er @@ -556,25 +457,136 @@ deriving (Show, Typeable) instance Exception ToEventRawException -encode :: (With m, MonadFailure YamlException m)- => YamlEncoder m ()- -> m B.ByteString-encode = withEmitter . runReaderT+decode :: SC.StreamChunk c Event+ => MonadCatchIO m+ => B.ByteString+ -> EnumeratorGM c Event m a+decode bs i = do+ fp <- liftIO $ mallocForeignPtrBytes parserSize+ res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize+ flip finally (liftIO $ withForeignPtr fp c_yaml_parser_delete) $+ if (res == 0)+ then return $ throwErr $ Err "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 -encodeFile :: (With m, MonadFailure YamlException m)+decodeFile :: SC.StreamChunk c Event+ => MonadCatchIO m => FilePath- -> YamlEncoder m ()- -> m ()-encodeFile filePath = withEmitterFile filePath . runReaderT+ -> EnumeratorGM c Event m a+decodeFile file i = do+ fp <- liftIO $ mallocForeignPtrBytes parserSize+ res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize+ flip finally (liftIO $ withForeignPtr fp c_yaml_parser_delete) $+ if (res == 0)+ then return $ throwErr $ Err "Yaml out of memory"+ else do+ file' <- liftIO+ $ withCString file $ \file' -> withCString "r" $ \r' ->+ c_fopen file' r'+ if (file' == nullPtr)+ then return $ throwErr $ Err+ $ "Yaml file not found: " ++ file+ else do+ liftIO $ withForeignPtr fp $ \p ->+ c_yaml_parser_set_input_file p file'+ finally (runParser fp i) $ liftIO $ do+ c_fclose file'+ withForeignPtr fp c_yaml_parser_delete -decode :: (With m, MonadFailure YamlException m)- => B.ByteString- -> YamlDecoder m a- -> m a-decode bs dec = withParser bs $ runReaderT dec+runParser :: SC.StreamChunk c Event+ => MonadCatchIO m+ => ForeignPtr ParserStruct+ -> IterateeG c Event m a+ -> m (IterateeG c Event m a)+runParser fp iter = do+ e <- liftIO $ withForeignPtr fp parserParseOne'+ case e of+ Left err -> return $ throwErr $ Err $ show err+ Right Nothing -> return iter+ Right (Just ev) -> do+ igv <- runIter iter $ Chunk $ SC.fromList [ev]+ case igv of+ Done a _ -> return $ return a+ Cont iter' Nothing -> runParser fp iter'+ Cont _ (Just err) -> return $ throwErr err -decodeFile :: (With m, MonadFailure YamlException m)+parserParseOne' :: Parser+ -> IO (Either String (Maybe Event))+parserParseOne' parser = allocaBytes eventSize $ \er -> do+ res <- liftIO $ c_yaml_parser_parse parser er+ flip finally (c_yaml_event_delete er) $+ if res == 0+ then do+ problem <- makeString c_get_parser_error_problem parser+ context <- makeString c_get_parser_error_context parser+ offset <- c_get_parser_error_offset parser+ return $ Left $ concat+ [ "YAML parse error: "+ , problem+ , "\nContext: "+ , context+ , "\nOffset: "+ , show offset+ , "\n"+ ]+ else liftIO $ Right <$> getEvent er++encode :: SC.StreamChunk c Event+ => MonadIO m+ => IterateeG c Event m B.ByteString+encode = joinIM $ liftIO $ do+ fp <- mallocForeignPtrBytes emitterSize+ res <- withForeignPtr fp c_yaml_emitter_initialize+ when (res == 0) $ fail "c_yaml_emitter_initialize failed"+ buf <- mallocForeignPtrBytes bufferSize+ withForeignPtr buf c_buffer_init+ withForeignPtr fp $+ \emitter -> withForeignPtr buf $+ \b -> c_my_emitter_set_output emitter b+ return $ runEmitter (go buf) fp+ where+ go buf = withForeignPtr buf $ \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 :: SC.StreamChunk c Event+ => MonadIO m => FilePath- -> YamlDecoder m a- -> m a-decodeFile fp dec = withFileParser fp $ runReaderT dec+ -> IterateeG c Event m ()+encodeFile filePath = joinIM $ liftIO $ do+ fp <- mallocForeignPtrBytes emitterSize+ res <- withForeignPtr fp c_yaml_emitter_initialize+ when (res == 0) $ fail "c_yaml_emitter_initialize failed"+ file <- withCString filePath $+ \filePath' -> withCString "w" $+ \w' -> c_fopen filePath' w'+ when (file == nullPtr) $ fail $ "could not open file for write: " ++ filePath+ withForeignPtr fp $ flip c_yaml_emitter_set_output_file file+ return $ runEmitter (c_fclose file) fp++runEmitter :: SC.StreamChunk c Event+ => MonadIO m+ => IO a+ -> ForeignPtr EmitterStruct+ -> IterateeG c Event m a+runEmitter close fp = IterateeG go+ where+ go (EOF x) = do+ liftIO $ withForeignPtr fp c_yaml_emitter_delete+ a <- liftIO close+ return $ Done a $ EOF x+ go (Chunk c) = do+ liftIO $ withForeignPtr fp $ \emitter ->+ LL.mapM_ (\e -> toEventRaw e $ c_yaml_emitter_emit emitter) c+ return $ Cont (runEmitter close fp) Nothing
c/helper.c view
@@ -108,6 +108,26 @@ return e->data.scalar.style; } +unsigned char * get_scalar_anchor(yaml_event_t *e)+{+ return e->data.scalar.anchor;+}++unsigned char * get_sequence_start_anchor(yaml_event_t *e)+{+ return e->data.sequence_start.anchor;+}++unsigned char * get_mapping_start_anchor(yaml_event_t *e)+{+ return e->data.mapping_start.anchor;+}++unsigned char * get_alias_anchor(yaml_event_t *e)+{+ return e->data.alias.anchor;+}+ int yaml_parser_set_input_filename(yaml_parser_t *parser, const char *filename) { FILE *in = fopen(filename, "r");
c/helper.h view
@@ -23,11 +23,18 @@ int simple_document_start(yaml_event_t *e); int get_event_type(yaml_event_t *e);+ unsigned char * get_scalar_value(yaml_event_t *e); unsigned long get_scalar_length(yaml_event_t *e); unsigned char * get_scalar_tag(yaml_event_t *e); unsigned long get_scalar_tag_len(yaml_event_t *e);+ int get_scalar_style(yaml_event_t *e);++unsigned char * get_scalar_anchor(yaml_event_t *e);+unsigned char * get_sequence_start_anchor(yaml_event_t *e);+unsigned char * get_mapping_start_anchor(yaml_event_t *e);+unsigned char * get_alias_anchor(yaml_event_t *e); #endif /* __HELPER_H__ */
runtests.hs view
@@ -1,99 +1,167 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-} import Test.Framework (defaultMain) import Text.Libyaml import qualified Data.ByteString.Char8 as B8-import Control.Monad.Trans ---import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit---import Test.Framework.Providers.QuickCheck (testProperty) import Test.HUnit hiding (Test, path)---import Test.QuickCheck +import Data.Iteratee hiding (filter, length, foldl')+import Data.List (foldl')++import System.Directory+import Control.Monad+ main :: IO () main = defaultMain- [ testCase "count scalars" caseCountScalars+ [ 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 -> IterateeG [] Event IO Int+counter pred' acc =+ IterateeG go+ where+ go (EOF x) = return $ Done acc $ EOF x+ go (Chunk c) =+ let acc' = length (filter pred' c) + acc+ in return $ Cont (counter pred' acc') Nothing++caseHelper :: String+ -> (Event -> Bool)+ -> Int+ -> Assertion+caseHelper yamlString pred' expRes = do+ res <- decode (B8.pack yamlString) (counter pred' 0) >>= run+ 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- res <- decode yamlBS $ counter accum+ res <- decode yamlBS (counter' accum) >>= run res @?= (7, 1, 2) where yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval" yamlBS = B8.pack yamlString- counter (s, l, m) = do- e <- parseEvent- case e of- EventScalar {} -> counter (s + 1, l, m)- EventSequenceStart -> counter (s, l + 1, m)- EventMappingStart -> counter (s, l, m + 1)- EventNone -> return (s, l, m)- _ -> counter (s, l, m)+ counter' acc = IterateeG $ \s ->+ case s of+ EOF x -> return $ Done acc $ EOF x+ Chunk c ->+ let acc' = foldl' adder acc c+ in return $ Cont (counter' acc') Nothing+ 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- res <- decodeFile filePath $ dec accum+ res <- decodeFile filePath (dec accum) >>= run res @?= (length expected, expected) where expected = "this one is just a little bit bigger than the others" filePath = "test/largest-string.yaml"- dec (i, s) = do- e <- parseEvent- case e of- (EventScalar bs _ _) -> do- let s' = B8.unpack bs- i' = length s'- dec $ if i' > i then (i', s') else (i, s)- EventNone -> return (i, s)- _ -> dec (i, s)+ dec acc = IterateeG $ \s ->+ case s of+ EOF x -> return $ Done acc $ EOF x+ Chunk c ->+ let acc' = foldl' adder acc c+ in return $ Cont (dec acc') Nothing+ 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- eList <- decode yamlBS $ dec id- bs <- encode $ mapM_ emitEvent eList- eList2 <- decode bs $ dec id+ eList <- decode yamlBS (dec []) >>= run+ bs <- enumPure1Chunk eList encode >>= run+ eList2 <- decode bs (dec []) >>= run map MyEvent eList @=? map MyEvent eList2 where yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n" yamlBS = B8.pack yamlString- dec front = do- e <- parseEvent- case e of- EventNone -> return $ front []- _ -> dec $ front . (:) e+ dec front = IterateeG $ \s ->+ case s of+ EOF x -> return $ Done front $ EOF x+ Chunk c -> return $ Cont (dec $ front ++ c) Nothing +removeFile' :: FilePath -> IO ()+removeFile' fp = do+ x <- doesFileExist fp+ when x $ removeFile fp+ caseEncodeDecodeFile :: Assertion caseEncodeDecodeFile = do- eList <- decodeFile filePath $ dec id- encodeFile tmpPath $ mapM_ emitEvent eList- eList2 <- decodeFile filePath $ dec id+ removeFile' tmpPath+ eList <- decodeFile filePath (dec []) >>= run+ enumPure1Chunk eList (encodeFile tmpPath) >>= run+ eList2 <- decodeFile filePath (dec []) >>= run map MyEvent eList @=? map MyEvent eList2 where filePath = "test/largest-string.yaml" tmpPath = "tmp.yaml"- dec front = do- e <- parseEvent- case e of- EventNone -> return $ front []- _ -> dec $ front . (:) e--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+ dec front = IterateeG $ \s ->+ case s of+ EOF x -> return $ Done front $ EOF x+ Chunk c -> return $ Cont (dec $ front ++ c) Nothing caseInterleave :: Assertion caseInterleave = do- decodeFile filePath $ encodeFile tmpPath inside- decodeFile tmpPath $ encodeFile tmpPath2 inside+ removeFile' tmpPath+ removeFile' tmpPath2+ decodeFile filePath (encodeFile tmpPath :: IterateeG [] Event IO ()) >>= run+ decodeFile tmpPath (encodeFile tmpPath2 :: IterateeG [] Event IO ()) >>= run f1 <- readFile tmpPath f2 <- readFile tmpPath2 f1 @=? f2@@ -101,9 +169,21 @@ filePath = "test/largest-string.yaml" tmpPath = "tmp.yaml" tmpPath2 = "tmp2.yaml"- inside :: YamlEncoder (YamlDecoder IO) ()- inside = do- e <- lift parseEvent- case e of- EventNone -> return ()- _ -> emitEvent e >> inside++caseDecodeInvalidDocument :: Assertion+caseDecodeInvalidDocument = do+ x <- decode yamlBS ignore+ y <- runIter x $ EOF Nothing+ case y of+ Cont _ _ -> return ()+ _ -> 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 :: IterateeG [] Event IO ()+ ignore = IterateeG $ \s ->+ case s of+ EOF x -> return $ Done () $ EOF x+ Chunk _c -> return $ Cont ignore Nothing
yaml.cabal view
@@ -1,8 +1,8 @@ name: yaml-version: 0.2.1+version: 0.3.0 license: BSD3 license-file: LICENSE-author: Michael Snoyman <michael@snoyman.com>+author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com> maintainer: Michael Snoyman <michael@snoyman.com> synopsis: Low-level binding to the libyaml C library. description: Provides support for parsing and emitting Yaml documents. Includes the full C library in the package so you don't need to worry about any non-Haskell dependencies.@@ -15,14 +15,12 @@ c/yaml_private.h, c/yaml.h -flag transformers_02- description: transformers = 0.2.*+flag nolib+ description: Skip building the library+ default: False flag buildtests description: Build the executable to run unit tests default: False-flag nolib- description: Skip building of the library- default: False library if flag(nolib)@@ -30,15 +28,13 @@ else Buildable: True build-depends: base >= 4 && < 5,- control-monad-failure >= 0.6.0 && < 0.7,- bytestring >= 0.9.1.4 && < 0.10+ transformers >= 0.1 && < 0.3,+ bytestring >= 0.9.1.4 && < 0.10,+ iteratee >= 0.3.5 && < 0.4,+ MonadCatchIO-transformers >= 0.2.2 && < 0.3,+ ListLike >= 1.0.1 && < 1.1 exposed-modules: Text.Libyaml- if flag(transformers_02)- build-depends: transformers >= 0.2 && < 0.3- CPP-OPTIONS: -DTRANSFORMERS_02- else- build-depends: transformers >= 0.1 && < 0.2- ghc-options: -Wall+ ghc-options: -Wall -auto-all -caf-all c-sources: c/helper.c, c/api.c, c/dumper.c,@@ -55,17 +51,15 @@ Buildable: True cpp-options: -DTEST build-depends: test-framework,- test-framework-quickcheck2, test-framework-hunit, HUnit,- QuickCheck >= 2 && < 3,+ directory, base >= 4 && < 5,- bytestring >= 0.9.1.4 && < 0.10- if flag(transformers_02)- build-depends: transformers >= 0.2 && < 0.3- CPP-OPTIONS: -DTRANSFORMERS_02- else- build-depends: transformers >= 0.1 && < 0.2+ transformers >= 0.1 && < 0.3,+ bytestring >= 0.9.1.4 && < 0.10,+ iteratee >= 0.3.5 && < 0.4,+ MonadCatchIO-transformers >= 0.2.2 && < 0.3,+ ListLike >= 1.0.1 && < 1.1 else Buildable: False ghc-options: -Wall