diff --git a/Text/Libyaml.hs b/Text/Libyaml.hs --- a/Text/Libyaml.hs +++ b/Text/Libyaml.hs @@ -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 diff --git a/c/helper.c b/c/helper.c --- a/c/helper.c +++ b/c/helper.c @@ -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"); diff --git a/c/helper.h b/c/helper.h --- a/c/helper.h +++ b/c/helper.h @@ -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__ */ diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -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 diff --git a/yaml.cabal b/yaml.cabal --- a/yaml.cabal +++ b/yaml.cabal @@ -1,8 +1,8 @@ name: yaml -version: 0.2.1 +version: 0.3.0 license: BSD3 license-file: LICENSE -author: Michael Snoyman +author: Michael Snoyman , Anton Ageev maintainer: Michael Snoyman 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