yaml 0.0.4 → 0.2.0
raw patch · 7 files changed
+557/−223 lines, 7 filesdep +HUnitdep +QuickCheckdep +control-monad-failuredep −bytestring-classdep −data-objectdep −haskell98dep ~bytestringnew-component:exe:runtests
Dependencies added: HUnit, QuickCheck, control-monad-failure, test-framework, test-framework-hunit, test-framework-quickcheck, transformers
Dependencies removed: bytestring-class, data-object, haskell98
Dependency ranges changed: bytestring
Files
- Text/Libyaml.hs +351/−103
- Text/Yaml.hs +0/−101
- c/api.c +2/−0
- c/helper.c +38/−7
- c/helper.h +10/−2
- runtests.hs +109/−0
- yaml.cabal +47/−10
Text/Libyaml.hs view
@@ -1,25 +1,136 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-} -{-# INCLUDE <yaml.h> #-}-{-# INCLUDE <helper.h> #-} 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
− Text/Yaml.hs
@@ -1,101 +0,0 @@---------------------------------------------------------------- Module : Text.Yaml--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- 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"
c/api.c view
@@ -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) {
c/helper.c view
@@ -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); }
c/helper.h view
@@ -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__ */
+ runtests.hs view
@@ -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
yaml.cabal view
@@ -1,28 +1,64 @@ name: yaml-version: 0.0.4+version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>-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