diff --git a/Text/Libyaml.hs b/Text/Libyaml.hs --- a/Text/Libyaml.hs +++ b/Text/Libyaml.hs @@ -1,25 +1,136 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} -{-# INCLUDE #-} -{-# INCLUDE #-} module Text.Libyaml -{- - ( + ( -- * The event stream Event (..) - , parserParse - , withParser - , emitEvents - , withEmitter - )-} where + , Style (..) + , Tag (..) + -- * Exceptions + , YamlException (..) + -- * Enumerator + , With (..) + -- * Encoder + , YamlEncoder + , YamlDecoder + , parseEvent + , emitEvent + -- * Higher level functions + , encode + , decode + , encodeFile + , decodeFile + ) where import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString +import Data.ByteString (ByteString) import Control.Monad import Foreign.C import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal.Alloc +import "transformers" Control.Monad.Trans +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) + +data Event = + EventNone + | EventStreamStart + | EventStreamEnd + | EventDocumentStart + | EventDocumentEnd + | EventAlias + | EventScalar !ByteString !Tag !Style + | EventSequenceStart + | EventSequenceEnd + | EventMappingStart + | EventMappingEnd + deriving (Show, Eq) + +data Style = Any + | Plain + | SingleQuoted + | DoubleQuoted + | Literal + | Folded + deriving (Show, Eq, Enum, Bounded, Ord) + +data Tag = StrTag + | FloatTag + | NullTag + | BoolTag + | SetTag + | IntTag + | SeqTag + | MapTag + | UriTag String + | NoTag + deriving (Show, Eq) + +tagToString :: Tag -> String +tagToString StrTag = "tag:yaml.org,2002:str" +tagToString FloatTag = "tag:yaml.org,2002:float" +tagToString NullTag = "tag:yaml.org,2002:null" +tagToString BoolTag = "tag:yaml.org,2002:bool" +tagToString SetTag = "tag:yaml.org,2002:set" +tagToString IntTag = "tag:yaml.org,2002:int" +tagToString SeqTag = "tag:yaml.org,2002:seq" +tagToString MapTag = "tag:yaml.org,2002:map" +tagToString (UriTag s) = s +tagToString NoTag = "" + +bsToTag :: ByteString -> Tag +bsToTag = stringToTag . B8.unpack + +stringToTag :: String -> Tag +stringToTag "tag:yaml.org,2002:str" = StrTag +stringToTag "tag:yaml.org,2002:float" = FloatTag +stringToTag "tag:yaml.org,2002:null" = NullTag +stringToTag "tag:yaml.org,2002:bool" = BoolTag +stringToTag "tag:yaml.org,2002:set" = SetTag +stringToTag "tag:yaml.org,2002:int" = IntTag +stringToTag "tag:yaml.org,2002:seq" = SeqTag +stringToTag "tag:yaml.org,2002:map" = MapTag +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 @@ -42,57 +153,113 @@ -> CULong -> IO () -withParser :: B.ByteString -> (Parser -> IO a) -> IO a -withParser bs f = do - allocaBytes parserSize $ \p -> - do - _res <- c_yaml_parser_initialize p - -- FIXME check res - let (fptr, offset, len) = B.toForeignPtr bs - ret <- withForeignPtr fptr $ \ptr -> - do - let ptr' = castPtr ptr `plusPtr` offset - len' = fromIntegral len - c_yaml_parser_set_input_string p ptr' len' - f p - c_yaml_parser_delete p - return ret +foreign import ccall unsafe "yaml_parser_set_input_file" + c_yaml_parser_set_input_file :: Parser + -> File + -> IO () -withEventRaw :: (EventRaw -> IO a) -> IO a -withEventRaw f = allocaBytes eventSize $ f +data FileStruct +type File = Ptr FileStruct +foreign import ccall unsafe "fopen" + c_fopen :: Ptr CChar + -> Ptr CChar + -> IO File + +foreign import ccall unsafe "fclose" + 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) + foreign import ccall unsafe "yaml_parser_parse" c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt foreign import ccall unsafe "yaml_event_delete" c_yaml_event_delete :: EventRaw -> IO () -foreign import ccall "print_parser_error" - c_print_parser_error :: Parser -> IO () +foreign import ccall "get_parser_error_problem" + c_get_parser_error_problem :: Parser -> IO (Ptr CUChar) -parserParseOne :: Parser -> IO Event -parserParseOne parser = withEventRaw $ \er -> do - res <- c_yaml_parser_parse parser er - when (res == 0) $ - c_print_parser_error parser >> fail "yaml_parser_parse failed" - event <- getEvent er - c_yaml_event_delete er - return event +foreign import ccall "get_parser_error_context" + c_get_parser_error_context :: Parser -> IO (Ptr CUChar) -data Event = - EventNone - | EventStreamStart - | EventStreamEnd - | EventDocumentStart - | EventDocumentEnd - | EventAlias - | EventScalar B.ByteString - | EventSequenceStart - | EventSequenceEnd - | EventMappingStart - | EventMappingEnd - deriving (Show) +foreign import ccall unsafe "get_parser_error_offset" + c_get_parser_error_offset :: Parser -> IO CULong +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 + data EventType = YamlNoEvent | YamlStreamStartEvent | YamlStreamEndEvent @@ -115,6 +282,15 @@ foreign import ccall unsafe "get_scalar_length" c_get_scalar_length :: EventRaw -> IO CULong +foreign import ccall unsafe "get_scalar_tag" + c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar) + +foreign import ccall unsafe "get_scalar_tag_len" + c_get_scalar_tag_len :: EventRaw -> IO CULong + +foreign import ccall unsafe "get_scalar_style" + c_get_scalar_style :: EventRaw -> IO CInt + getEvent :: EventRaw -> IO Event getEvent er = do et <- c_get_event_type er @@ -128,25 +304,27 @@ YamlScalarEvent -> do yvalue <- c_get_scalar_value er ylen <- c_get_scalar_length er + ytag <- c_get_scalar_tag er + ytag_len <- c_get_scalar_tag_len er + ystyle <- c_get_scalar_style er + let ytag_len' = fromEnum ytag_len 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'' - return $ EventScalar bs + tagbs <- + if ytag_len' == 0 + then return Data.ByteString.empty + else B.create ytag_len' + $ \dest -> B.memcpy dest ytag' (toEnum 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 -parserParse :: Parser -> IO [Event] -parserParse parser = do - event <- parserParseOne parser - case event of - EventStreamEnd -> return [event] - _ -> do - rest <- parserParse parser - return $! event : rest - -- Emitter data EmitterStruct @@ -174,44 +352,78 @@ foreign import ccall unsafe "get_buffer_used" c_get_buffer_used :: Buffer -> IO CULong -withBuffer :: (Buffer -> IO ()) -> IO B.ByteString -withBuffer f = do - allocaBytes bufferSize $ \b -> do - c_buffer_init b - f b - ptr' <- c_get_buffer_buff b - len <- c_get_buffer_used b - fptr <- newForeignPtr_ $ castPtr ptr' - return $! B.fromForeignPtr fptr 0 $ fromIntegral len +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 :: (Emitter -> IO ()) -> IO B.ByteString -withEmitter f = do - allocaBytes emitterSize $ \e -> do - _res <- c_yaml_emitter_initialize e - -- FIXME check res - bs <- withBuffer $ \b -> do - c_my_emitter_set_output e b - f e - c_yaml_emitter_delete e - return bs +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 "print_emitter_error" - c_print_emitter_error :: Emitter -> IO () +foreign import ccall unsafe "get_emitter_error" + c_get_emitter_error :: Emitter -> IO (Ptr CUChar) -emitEvents :: Emitter -> [Event] -> IO () -emitEvents _ [] = return () -emitEvents emitter (e:rest) = do - res <- toEventRaw e $ c_yaml_emitter_emit emitter - when (res == 0) $ - c_print_emitter_error emitter >> fail "yaml_emitter_emit failed" - emitEvents emitter rest +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 +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 @@ -224,10 +436,10 @@ -> Ptr CUChar -- anchor -> Ptr CUChar -- tag -> Ptr CUChar -- value - -> CInt - -> CInt - -> CInt - -> CInt + -> CInt -- length + -> CInt -- plain_implicit + -> CInt -- quoted_implicit + -> CInt -- style -> IO CInt foreign import ccall unsafe "simple_document_start" @@ -261,8 +473,8 @@ c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt toEventRaw :: Event -> (EventRaw -> IO a) -> IO a -toEventRaw e f = withEventRaw $ \er -> do - case e of +toEventRaw e f = allocaBytesR eventSize $ \er -> do + ret <- case e of EventStreamStart -> c_yaml_stream_start_event_initialize er @@ -273,20 +485,28 @@ c_simple_document_start er EventDocumentEnd -> c_yaml_document_end_event_initialize er 1 - EventScalar bs -> do + EventScalar bs thetag style -> do let (fvalue, offset, len) = B.toForeignPtr bs withForeignPtr fvalue $ \value -> do let value' = value `plusPtr` offset len' = fromIntegral len - c_yaml_scalar_event_initialize - er - nullPtr - nullPtr - value' - len' - 0 - 1 - 0 -- YAML_ANY_SCALAR_STYLE + value'' = if ptrToIntPtr value' == 0 + then intPtrToPtr 1 -- c/api.c:827 + else value' + 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 -> c_yaml_sequence_start_event_initialize er @@ -307,4 +527,32 @@ c_yaml_mapping_end_event_initialize er EventAlias -> error "toEventRaw: EventAlias not supported" EventNone -> error "toEventRaw: EventNone not supported" + unless (ret == 1) $ throwIO $ ToEventRawException ret f er + +newtype ToEventRawException = ToEventRawException CInt + deriving (Show, Typeable) +instance Exception ToEventRawException + +encode :: (With m, MonadFailure YamlException m) + => YamlEncoder m () + -> m B.ByteString +encode = withEmitter . runReaderT + +encodeFile :: (With m, MonadFailure YamlException m) + => FilePath + -> YamlEncoder m () + -> m () +encodeFile filePath = withEmitterFile filePath . runReaderT + +decode :: (With m, MonadFailure YamlException m) + => B.ByteString + -> YamlDecoder m a + -> m a +decode bs dec = withParser bs $ runReaderT dec + +decodeFile :: (With m, MonadFailure YamlException m) + => FilePath + -> YamlDecoder m a + -> m a +decodeFile fp dec = withFileParser fp $ runReaderT dec diff --git a/Text/Yaml.hs b/Text/Yaml.hs deleted file mode 100644 --- a/Text/Yaml.hs +++ /dev/null @@ -1,101 +0,0 @@ ---------------------------------------------------------- --- --- Module : Text.Yaml --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Provides a user friendly interface for serializing Yaml data. --- ---------------------------------------------------------- - -module Text.Yaml - ( module Data.Object - , encode - , encodeFile - , decode - , decodeFile - ) where - -import Prelude hiding (readList) -import Text.Libyaml -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Class -import Data.Object -import System.IO.Unsafe -import Control.Arrow (first) - -encode :: (StrictByteString bs, ToObject o) => o -> bs -encode = unsafePerformIO . encode' - -decode :: (Monad m, StrictByteString bs, FromObject o) => bs -> m o -decode = unsafePerformIO . decode' - -encodeFile :: ToObject o => FilePath -> o -> IO () -encodeFile path o = encode' o >>= B.writeFile path - -decodeFile :: (Monad m, FromObject o) => FilePath -> IO (m o) -decodeFile path = do - c <- B.readFile path - decode' c - -encode' :: (StrictByteString bs, ToObject o) => o -> IO bs -encode' o = - let events = objectToEvents $ toObject o - result = withEmitter $ flip emitEvents $ events - in fromStrictByteString `fmap` result - -decode' :: (Monad m, StrictByteString bs, FromObject o) => bs -> IO (m o) -decode' bs = do - let bs' = toStrictByteString bs - events = withParser bs' parserParse - (fromObject . eventsToObject) `fmap` events - -objectToEvents :: Object -> [Event] -objectToEvents y = concat - [ [EventStreamStart, EventDocumentStart] - , writeSingle y - , [EventDocumentEnd, EventStreamEnd]] where - writeSingle :: Object -> [Event] - writeSingle (Scalar bs) = [EventScalar $ fromLazyByteString bs] - writeSingle (Sequence ys) = - (EventSequenceStart : concatMap writeSingle ys) - ++ [EventSequenceEnd] - writeSingle (Mapping pairs) = - EventMappingStart : concatMap writePair pairs ++ [EventMappingEnd] - writePair :: (BL.ByteString, Object) -> [Event] - writePair (k, v) = EventScalar (fromLazyByteString k) : writeSingle v - -eventsToObject :: [Event] -> Object -eventsToObject = fst . readSingle . dropWhile isIgnored where - isIgnored EventAlias = False - isIgnored (EventScalar _) = False - isIgnored EventSequenceStart = False - isIgnored EventSequenceEnd = False - isIgnored EventMappingStart = False - isIgnored EventMappingEnd = False - isIgnored _ = True - readSingle :: [Event] -> (Object, [Event]) - readSingle [] = error "readSingle: no more events" - readSingle (EventScalar bs:rest) = (Scalar $ toLazyByteString bs, rest) - readSingle (EventSequenceStart:rest) = readList [] rest - readSingle (EventMappingStart:rest) = readMap [] rest - readSingle (x:_) = error $ "readSingle: " ++ show x - readList :: [Object] -> [Event] -> (Object, [Event]) - readList nodes (EventSequenceEnd:rest) = - (Sequence $ reverse nodes, rest) - readList nodes events = - let (next, rest) = readSingle events - in readList (next : nodes) rest - readMap :: [(B.ByteString, Object)] -> [Event] -> (Object, [Event]) - readMap pairs (EventMappingEnd:rest) = - (Mapping $ map (first toLazyByteString) $ reverse pairs, rest) - readMap pairs (EventScalar bs:events) = - let (next, rest) = readSingle events - in readMap ((fromStrictByteString bs, next) : pairs) rest - readMap _ (e:_) = error $ "Unexpected event in readMap: " ++ show e - readMap _ [] = error "Unexpected empty event list in readMap" diff --git a/c/api.c b/c/api.c --- a/c/api.c +++ b/c/api.c @@ -824,6 +824,8 @@ yaml_char_t *value_copy = NULL; assert(event); /* Non-NULL event object is expected. */ + /* following line added for Haskell yaml library */ + if (!value && !length) value = ""; assert(value); /* Non-NULL anchor is expected. */ if (anchor) { diff --git a/c/helper.c b/c/helper.c --- a/c/helper.c +++ b/c/helper.c @@ -46,19 +46,26 @@ yaml_emitter_set_output(e, buffer_append, b); } -void print_parser_error(yaml_parser_t *p) +unsigned char const * get_parser_error_problem(yaml_parser_t *p) { - fprintf(stderr, "Problem: %s\nContext: %s\nOffset: %u\n", - p->problem, - p->context, - (unsigned int) p->problem_offset); + return p->problem; } -void print_emitter_error(yaml_emitter_t *e) +unsigned char const * get_parser_error_context(yaml_parser_t *p) { - fprintf(stderr, "%s\n", e->problem); + return p->context; } +unsigned int get_parser_error_offset(yaml_parser_t *p) +{ + return p->offset; +} + +unsigned char const * get_emitter_error(yaml_emitter_t *e) +{ + return e->problem; +} + int simple_document_start(yaml_event_t *e) { return yaml_document_start_event_initialize @@ -82,4 +89,28 @@ unsigned long get_scalar_length(yaml_event_t *e) { return e->data.scalar.length; +} + +unsigned char * get_scalar_tag(yaml_event_t *e) +{ + unsigned char *s = e->data.scalar.tag; + if (!s) s = ""; + return s; +} + +unsigned long get_scalar_tag_len(yaml_event_t *e) +{ + return strlen(get_scalar_tag(e)); +} + +int get_scalar_style(yaml_event_t *e) +{ + return e->data.scalar.style; +} + +int yaml_parser_set_input_filename(yaml_parser_t *parser, const char *filename) +{ + FILE *in = fopen(filename, "r"); + if (!in) return 0; + yaml_parser_set_input_file(parser, in); } diff --git a/c/helper.h b/c/helper.h --- a/c/helper.h +++ b/c/helper.h @@ -14,12 +14,20 @@ void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b); -void print_parser_error(yaml_parser_t *p); -void print_emitter_error(yaml_emitter_t *e); +unsigned char const * get_parser_error_problem(yaml_parser_t *p); +unsigned char const * get_parser_error_context(yaml_parser_t *p); +unsigned int get_parser_error_offset(yaml_parser_t *p); + +unsigned char const * get_emitter_error(yaml_emitter_t *e); + 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); #endif /* __HELPER_H__ */ diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,109 @@ +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 + +main :: IO () +main = defaultMain + [ testCase "count scalars" caseCountScalars + , testCase "largest string" caseLargestString + , testCase "encode/decode" caseEncodeDecode + , testCase "encode/decode file" caseEncodeDecodeFile + , testCase "interleaved encode/decode" caseInterleave + ] + +caseCountScalars :: Assertion +caseCountScalars = do + res <- decode yamlBS $ counter accum + 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) + accum = (0, 0, 0) :: (Int, Int, Int) + +caseLargestString :: Assertion +caseLargestString = do + res <- 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 (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) + accum = (0, "no strings found") + +caseEncodeDecode :: Assertion +caseEncodeDecode = do + eList <- decode yamlBS $ dec id + bs <- encode $ mapM_ emitEvent eList + eList2 <- decode bs $ dec id + 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 + +caseEncodeDecodeFile :: Assertion +caseEncodeDecodeFile = do + eList <- decodeFile filePath $ dec id + encodeFile tmpPath $ mapM_ emitEvent eList + eList2 <- decodeFile filePath $ dec id + 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 + +caseInterleave :: Assertion +caseInterleave = do + decodeFile filePath $ encodeFile tmpPath inside + decodeFile tmpPath $ encodeFile tmpPath2 inside + f1 <- readFile tmpPath + f2 <- readFile tmpPath2 + f1 @=? f2 + where + 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 diff --git a/yaml.cabal b/yaml.cabal --- a/yaml.cabal +++ b/yaml.cabal @@ -1,28 +1,64 @@ name: yaml -version: 0.0.4 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman -synopsis: Support for serialising Haskell to and from Yaml. -description: Binds to the libyaml library +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. category: Web stability: unstable cabal-version: >= 1.2 build-type: Simple -homepage: http://github.com/snoyberg/yaml/tree/master +homepage: http://github.com/snoyberg/yaml/ extra-source-files: c/helper.h, c/yaml_private.h, c/yaml.h +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) + Buildable: False + else + Buildable: True build-depends: base >= 4 && < 5, - bytestring-class, - data-object >= 0.0.2, - bytestring >= 0.9.1.4 && < 1, - haskell98 - exposed-modules: Text.Yaml - other-modules: Text.Libyaml + transformers >= 0.1 && < 0.2, + control-monad-failure >= 0.6.0 && < 0.7, + bytestring >= 0.9.1.4 && < 0.10 + exposed-modules: Text.Libyaml + ghc-options: -Wall -auto-all -caf-all + c-sources: c/helper.c, + c/api.c, + c/dumper.c, + c/emitter.c, + c/loader.c, + c/parser.c, + c/reader.c, + c/scanner.c, + c/writer.c + include-dirs: c + +executable runtests + if flag(buildtests) + Buildable: True + cpp-options: -DTEST + build-depends: test-framework, + test-framework-quickcheck, + test-framework-hunit, + HUnit, + QuickCheck >= 1 && < 2, + base >= 4 && < 5, + transformers >= 0.1 && < 0.2, + control-monad-failure >= 0.6.0 && < 0.7, + bytestring >= 0.9.1.4 && < 0.10 + else + Buildable: False ghc-options: -Wall c-sources: c/helper.c, c/api.c, @@ -34,3 +70,4 @@ c/scanner.c, c/writer.c include-dirs: c + main-is: runtests.hs