libyaml-0.1.4/c/0000755000000000000000000000000014423636144011564 5ustar0000000000000000libyaml-0.1.4/include/0000755000000000000000000000000014423636144012765 5ustar0000000000000000libyaml-0.1.4/src/0000755000000000000000000000000014370231742012125 5ustar0000000000000000libyaml-0.1.4/src/Text/0000755000000000000000000000000014423636034013053 5ustar0000000000000000libyaml-0.1.4/src/Text/Libyaml.hs0000644000000000000000000007115714423636034015013 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Low-level, streaming YAML interface. For a higher-level interface, see -- "Data.Yaml". module Text.Libyaml ( -- * The event stream MarkedEvent(..) , Event (..) , Style (..) , SequenceStyle (..) , MappingStyle (..) , Tag (..) , AnchorName , Anchor -- * Encoding and decoding , encode , encodeWith , decode , decodeMarked , encodeFile , decodeFile , decodeFileMarked , encodeFileWith , FormatOptions , defaultFormatOptions , setWidth , setTagRendering , renderScalarTags , renderAllTags , renderNoTags , renderUriTags -- * Error handling , YamlException (..) , YamlMark (..) ) where import Prelude hiding (pi) import Data.Bits ((.|.)) import Foreign.C import Foreign.Ptr import Foreign.ForeignPtr #if MIN_VERSION_base(4,7,0) import Foreign.ForeignPtr.Unsafe #endif import Foreign.Marshal.Alloc import qualified System.Posix.Internals as Posix #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Exception (mask_, throwIO, Exception, finally) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Conduit hiding (Source, Sink, Conduit) import Data.Data import Data.ByteString (ByteString, packCString, packCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as BU #if WINDOWS && __GLASGOW_HASKELL__ >= 806 import System.Directory (removeFile) import qualified Control.Exception #endif data Event = EventStreamStart | EventStreamEnd | EventDocumentStart | EventDocumentEnd | EventAlias !AnchorName | EventScalar !ByteString !Tag !Style !Anchor | EventSequenceStart !Tag !SequenceStyle !Anchor | EventSequenceEnd | EventMappingStart !Tag !MappingStyle !Anchor | EventMappingEnd deriving (Show, Eq) -- | Event with start and end marks. -- -- @since 0.10.4.0 data MarkedEvent = MarkedEvent { yamlEvent :: Event , yamlStartMark :: YamlMark , yamlEndMark :: YamlMark } -- | Style for scalars - e.g. quoted / folded -- data Style = Any | Plain | SingleQuoted | DoubleQuoted | Literal | Folded | PlainNoTag deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable) -- | Style for sequences - e.g. block or flow -- -- @since 0.9.0 data SequenceStyle = AnySequence | BlockSequence | FlowSequence deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable) -- | Style for mappings - e.g. block or flow -- -- @since 0.9.0 data MappingStyle = AnyMapping | BlockMapping | FlowMapping deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable) data Tag = StrTag | FloatTag | NullTag | BoolTag | SetTag | IntTag | SeqTag | MapTag | UriTag String | NoTag deriving (Show, Eq, Read, Data, Typeable) tagSuppressed :: Tag -> Bool tagSuppressed (NoTag) = True tagSuppressed (UriTag "") = True tagSuppressed _ = False type AnchorName = String type Anchor = Maybe AnchorName 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 ParserStruct type Parser = Ptr ParserStruct parserSize :: Int parserSize = 480 data EventRawStruct type EventRaw = Ptr EventRawStruct eventSize :: Int eventSize = 104 foreign import ccall unsafe "yaml_parser_initialize" c_yaml_parser_initialize :: Parser -> IO CInt foreign import ccall unsafe "yaml_parser_delete" c_yaml_parser_delete :: Parser -> IO () foreign import ccall unsafe "yaml_parser_set_input_string" c_yaml_parser_set_input_string :: Parser -> Ptr CUChar -> CULong -> IO () foreign import ccall unsafe "yaml_parser_set_input_file" c_yaml_parser_set_input_file :: Parser -> File -> IO () data MarkRawStruct type MarkRaw = Ptr MarkRawStruct foreign import ccall unsafe "get_mark_index" c_get_mark_index :: MarkRaw -> IO CULong foreign import ccall unsafe "get_mark_line" c_get_mark_line :: MarkRaw -> IO CULong foreign import ccall unsafe "get_mark_column" c_get_mark_column :: MarkRaw -> IO CULong getMark :: MarkRaw -> IO YamlMark getMark m = YamlMark <$> (fromIntegral <$> c_get_mark_index m) <*> (fromIntegral <$> c_get_mark_line m) <*> (fromIntegral <$> c_get_mark_column m) data FileStruct type File = Ptr FileStruct #ifdef WINDOWS foreign import ccall unsafe "_fdopen" #else foreign import ccall unsafe "fdopen" #endif c_fdopen :: CInt -> Ptr CChar -> IO File foreign import ccall unsafe "fclose" c_fclose :: File -> IO CInt foreign import ccall unsafe "fclose_helper" c_fclose_helper :: File -> IO CInt 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 "get_parser_error_problem" c_get_parser_error_problem :: Parser -> IO (Ptr CUChar) foreign import ccall "get_parser_error_context" c_get_parser_error_context :: Parser -> IO (Ptr CUChar) foreign import ccall unsafe "get_parser_error_mark" c_get_parser_error_mark :: Parser -> IO MarkRaw makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String makeString f a = do cchar <- castPtr `liftM` f a if cchar == nullPtr then return "" else liftIO $ peekCString cchar data EventType = YamlNoEvent | YamlStreamStartEvent | YamlStreamEndEvent | YamlDocumentStartEvent | YamlDocumentEndEvent | YamlAliasEvent | YamlScalarEvent | YamlSequenceStartEvent | YamlSequenceEndEvent | YamlMappingStartEvent | YamlMappingEndEvent deriving (Enum,Show) foreign import ccall unsafe "get_event_type" c_get_event_type :: EventRaw -> IO CInt foreign import ccall unsafe "get_start_mark" c_get_start_mark :: EventRaw -> IO MarkRaw foreign import ccall unsafe "get_end_mark" c_get_end_mark :: EventRaw -> IO MarkRaw foreign import ccall unsafe "get_scalar_value" c_get_scalar_value :: EventRaw -> IO (Ptr CUChar) 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_style" c_get_scalar_style :: EventRaw -> IO CInt 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_sequence_start_style" c_get_sequence_start_style :: EventRaw -> IO CInt foreign import ccall unsafe "get_sequence_start_tag" c_get_sequence_start_tag :: EventRaw -> IO (Ptr CUChar) foreign import ccall unsafe "get_mapping_start_anchor" c_get_mapping_start_anchor :: EventRaw -> IO CString foreign import ccall unsafe "get_mapping_start_style" c_get_mapping_start_style :: EventRaw -> IO CInt foreign import ccall unsafe "get_mapping_start_tag" c_get_mapping_start_tag :: EventRaw -> IO (Ptr CUChar) foreign import ccall unsafe "get_alias_anchor" c_get_alias_anchor :: EventRaw -> IO CString readAnchor :: (EventRaw -> IO CString) -> EventRaw -> IO Anchor readAnchor getAnchor er = do yanchor <- getAnchor er if yanchor == nullPtr then return Nothing else Just <$> peekCString yanchor readStyle :: (Enum a) => (EventRaw -> IO CInt) -> EventRaw -> IO a readStyle getStyle er = toEnum . fromEnum <$> getStyle er readTag :: (EventRaw -> IO (Ptr CUChar)) -> EventRaw -> IO Tag readTag getTag er = bsToTag <$> (getTag er >>= packCString . castPtr) getEvent :: EventRaw -> IO (Maybe MarkedEvent) getEvent er = do et <- c_get_event_type er startMark <- c_get_start_mark er >>= getMark endMark <- c_get_end_mark er >>= getMark event <- case toEnum $ fromEnum et of 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 let yvalue' = castPtr yvalue let ylen' = fromEnum ylen bs <- packCStringLen (yvalue', ylen') tag <- readTag c_get_scalar_tag er style <- readStyle c_get_scalar_style er anchor <- readAnchor c_get_scalar_anchor er return $ Just $ EventScalar bs tag style anchor YamlSequenceStartEvent -> do tag <- readTag c_get_sequence_start_tag er style <- readStyle c_get_sequence_start_style er anchor <- readAnchor c_get_sequence_start_anchor er return $ Just $ EventSequenceStart tag style anchor YamlSequenceEndEvent -> return $ Just EventSequenceEnd YamlMappingStartEvent -> do tag <- readTag c_get_mapping_start_tag er style <- readStyle c_get_mapping_start_style er anchor <- readAnchor c_get_mapping_start_anchor er return $ Just $ EventMappingStart tag style anchor YamlMappingEndEvent -> return $ Just EventMappingEnd return $ (\e -> MarkedEvent e startMark endMark) <$> event -- Emitter data EmitterStruct type Emitter = Ptr EmitterStruct emitterSize :: Int emitterSize = 432 foreign import ccall unsafe "yaml_emitter_initialize" c_yaml_emitter_initialize :: Emitter -> IO CInt foreign import ccall unsafe "yaml_emitter_delete" c_yaml_emitter_delete :: Emitter -> IO () data BufferStruct type Buffer = Ptr BufferStruct bufferSize :: Int bufferSize = 16 foreign import ccall unsafe "buffer_init" c_buffer_init :: Buffer -> IO () foreign import ccall unsafe "get_buffer_buff" c_get_buffer_buff :: Buffer -> IO (Ptr CUChar) foreign import ccall unsafe "get_buffer_used" c_get_buffer_used :: Buffer -> IO CULong foreign import ccall unsafe "my_emitter_set_output" c_my_emitter_set_output :: Emitter -> Buffer -> IO () #ifndef __NO_UNICODE__ foreign import ccall unsafe "yaml_emitter_set_unicode" c_yaml_emitter_set_unicode :: Emitter -> CInt -> IO () #endif foreign import ccall unsafe "yaml_emitter_set_output_file" c_yaml_emitter_set_output_file :: Emitter -> File -> IO () foreign import ccall unsafe "yaml_emitter_set_width" c_yaml_emitter_set_width :: Emitter -> CInt -> IO () foreign import ccall unsafe "yaml_emitter_emit" c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt foreign import ccall unsafe "yaml_stream_start_event_initialize" c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt foreign import ccall unsafe "yaml_stream_end_event_initialize" c_yaml_stream_end_event_initialize :: EventRaw -> IO CInt foreign import ccall unsafe "yaml_scalar_event_initialize" c_yaml_scalar_event_initialize :: EventRaw -> Ptr CUChar -- anchor -> Ptr CUChar -- tag -> Ptr CUChar -- value -> CInt -- length -> CInt -- plain_implicit -> CInt -- quoted_implicit -> CInt -- style -> IO CInt foreign import ccall unsafe "simple_document_start" c_simple_document_start :: EventRaw -> IO CInt foreign import ccall unsafe "yaml_document_end_event_initialize" c_yaml_document_end_event_initialize :: EventRaw -> CInt -> IO CInt foreign import ccall unsafe "yaml_sequence_start_event_initialize" c_yaml_sequence_start_event_initialize :: EventRaw -> Ptr CUChar -> Ptr CUChar -> CInt -> CInt -> IO CInt foreign import ccall unsafe "yaml_sequence_end_event_initialize" c_yaml_sequence_end_event_initialize :: EventRaw -> IO CInt foreign import ccall unsafe "yaml_mapping_start_event_initialize" c_yaml_mapping_start_event_initialize :: EventRaw -> Ptr CUChar -> Ptr CUChar -> CInt -> CInt -> IO CInt 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 :: FormatOptions -> Event -> (EventRaw -> IO a) -> IO a toEventRaw opts e f = allocaBytes eventSize $ \er -> do ret <- case e of EventStreamStart -> c_yaml_stream_start_event_initialize er 0 -- YAML_ANY_ENCODING EventStreamEnd -> c_yaml_stream_end_event_initialize er EventDocumentStart -> c_simple_document_start er EventDocumentEnd -> c_yaml_document_end_event_initialize er 1 EventScalar bs thetag style0 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 pi0 = tagsImplicit e (pi, style) = case style0 of PlainNoTag -> (1, Plain) x -> (pi0, x) style' = toEnum $ fromEnum style tagP = castPtr tag' case anchor of Nothing -> c_yaml_scalar_event_initialize er nullPtr -- anchor tagP -- tag value' -- value len' -- length pi -- plain_implicit pi -- 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 pi -- quoted_implicit style' -- style EventSequenceStart tag style Nothing -> withCString (tagToString tag) $ \tag' -> do let tagP = castPtr tag' c_yaml_sequence_start_event_initialize er nullPtr tagP (tagsImplicit e) (toEnum $ fromEnum style) EventSequenceStart tag style (Just anchor) -> withCString (tagToString tag) $ \tag' -> do let tagP = castPtr tag' withCString anchor $ \anchor' -> do let anchorP = castPtr anchor' c_yaml_sequence_start_event_initialize er anchorP tagP (tagsImplicit e) (toEnum $ fromEnum style) EventSequenceEnd -> c_yaml_sequence_end_event_initialize er EventMappingStart tag style Nothing -> withCString (tagToString tag) $ \tag' -> do let tagP = castPtr tag' c_yaml_mapping_start_event_initialize er nullPtr tagP (tagsImplicit e) (toEnum $ fromEnum style) EventMappingStart tag style (Just anchor) -> withCString (tagToString tag) $ \tag' -> do withCString anchor $ \anchor' -> do let tagP = castPtr tag' let anchorP = castPtr anchor' c_yaml_mapping_start_event_initialize er anchorP tagP (tagsImplicit e) (toEnum $ fromEnum style) EventMappingEnd -> c_yaml_mapping_end_event_initialize er 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 where tagsImplicit (EventScalar _ t _ _) | tagSuppressed t = 1 tagsImplicit (EventMappingStart t _ _) | tagSuppressed t = 1 tagsImplicit (EventSequenceStart t _ _) | tagSuppressed t = 1 tagsImplicit evt = toImplicitParam $ formatOptionsRenderTags opts evt newtype ToEventRawException = ToEventRawException CInt deriving (Show, Typeable) instance Exception ToEventRawException -- | Create a conduit that yields events from a bytestring. decode :: MonadResource m => B.ByteString -> ConduitM i Event m () decode = mapOutput yamlEvent . decodeMarked -- | Create a conduit that yields marked events from a bytestring. -- -- This conduit will yield identical events to that of "decode", but also -- includes start and end marks for each event. -- -- @since 0.10.4.0 decodeMarked :: MonadResource m => B.ByteString -> ConduitM i MarkedEvent m () decodeMarked bs | B8.null bs = return () decodeMarked bs = bracketP alloc cleanup (runParser . fst) where alloc = mask_ $ do ptr <- mallocBytes parserSize res <- c_yaml_parser_initialize ptr if res == 0 then do c_yaml_parser_delete ptr free ptr throwIO $ YamlException "Yaml out of memory" else do let (bsfptr, offset, len) = B.toForeignPtr bs let bsptrOrig = unsafeForeignPtrToPtr bsfptr let bsptr = castPtr bsptrOrig `plusPtr` offset c_yaml_parser_set_input_string ptr bsptr (fromIntegral len) return (ptr, bsfptr) cleanup (ptr, bsfptr) = do touchForeignPtr bsfptr c_yaml_parser_delete ptr free ptr -- XXX copied from GHC.IO.FD std_flags, read_flags, output_flags, write_flags :: CInt std_flags = Posix.o_NOCTTY output_flags = std_flags .|. Posix.o_CREAT .|. Posix.o_TRUNC read_flags = std_flags .|. Posix.o_RDONLY write_flags = output_flags .|. Posix.o_WRONLY -- | Open a C FILE* from a file path, using internal GHC API to work correctly -- on all platforms, even on non-ASCII filenames. The opening mode must be -- indicated via both 'rawOpenFlags' and 'openMode'. openFile :: FilePath -> CInt -> String -> IO File openFile file rawOpenFlags openMode = do fd <- liftIO $ Posix.withFilePath file $ \file' -> Posix.c_open file' rawOpenFlags 0o666 if fd /= (-1) then withCString openMode $ \openMode' -> c_fdopen fd openMode' else return nullPtr -- | Creata a conduit that yields events from a file. decodeFile :: MonadResource m => FilePath -> ConduitM i Event m () decodeFile = mapOutput yamlEvent . decodeFileMarked -- | Create a conduit that yields marked events from a file. -- -- This conduit will yield identical events to that of "decodeFile", but also -- includes start and end marks for each event. -- -- @since 0.10.4.0 decodeFileMarked :: MonadResource m => FilePath -> ConduitM i MarkedEvent m () decodeFileMarked file = bracketP alloc cleanup (runParser . fst) where alloc = mask_ $ do ptr <- mallocBytes parserSize res <- c_yaml_parser_initialize ptr if res == 0 then do c_yaml_parser_delete ptr free ptr throwIO $ YamlException "Yaml out of memory" else do file' <- openFile file read_flags "r" if file' == nullPtr then do c_yaml_parser_delete ptr free ptr throwIO $ YamlException $ "Yaml file not found: " ++ file else do c_yaml_parser_set_input_file ptr file' return (ptr, file') cleanup (ptr, file') = do res <- c_fclose_helper file' when (res /= 0) $ throwIO $ YamlException $ "could not close file: " ++ file c_yaml_parser_delete ptr free ptr runParser :: MonadResource m => Parser -> ConduitM i MarkedEvent m () runParser parser = do e <- liftIO $ parserParseOne' parser case e of Left err -> liftIO $ throwIO err Right Nothing -> return () Right (Just ev) -> yield ev >> runParser parser parserParseOne' :: Parser -> IO (Either YamlException (Maybe MarkedEvent)) 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 problemMark <- c_get_parser_error_mark parser >>= getMark return $ Left $ YamlParseException problem context problemMark else Right <$> getEvent er -- | Whether a tag should be rendered explicitly in the output or left -- implicit. -- -- @since 0.1.1.0 data TagRender = Explicit | Implicit deriving (Enum) toImplicitParam :: TagRender -> CInt toImplicitParam Explicit = 0 toImplicitParam Implicit = 1 -- | A value for 'formatOptionsRenderTags' that renders no -- collection tags but all scalar tags (unless suppressed with styles -- 'NoTag or 'PlainNoTag'). -- -- @since 0.1.1.0 renderScalarTags :: Event -> TagRender renderScalarTags (EventScalar _ _ _ _) = Explicit renderScalarTags (EventSequenceStart _ _ _) = Implicit renderScalarTags (EventMappingStart _ _ _) = Implicit renderScalarTags _ = Implicit -- | A value for 'formatOptionsRenderTags' that renders all -- tags (except 'NoTag' tag and 'PlainNoTag' style). -- -- @since 0.1.1.0 renderAllTags :: Event -> TagRender renderAllTags _ = Explicit -- | A value for 'formatOptionsRenderTags' that renders no -- tags. -- -- @since 0.1.1.0 renderNoTags :: Event -> TagRender renderNoTags _ = Implicit -- | A value for 'formatOptionsRenderCollectionTags' that renders tags -- which are instances of 'UriTag' -- -- @since 0.1.1.0 renderUriTags :: Event -> TagRender renderUriTags (EventScalar _ UriTag{} _ _) = Explicit renderUriTags (EventSequenceStart UriTag{} _ _) = Explicit renderUriTags (EventMappingStart UriTag{} _ _) = Explicit renderUriTags _ = Implicit -- | Contains options relating to the formatting (indendation, width) of the YAML output. -- -- @since 0.10.2.0 data FormatOptions = FormatOptions { formatOptionsWidth :: Maybe Int , formatOptionsRenderTags :: Event -> TagRender } -- | -- @since 0.10.2.0 defaultFormatOptions :: FormatOptions defaultFormatOptions = FormatOptions { formatOptionsWidth = Just 80 -- by default the width is set to 0 in the C code, which gets turned into 80 in yaml_emitter_emit_stream_start , formatOptionsRenderTags = renderScalarTags } -- | Set the maximum number of columns in the YAML output, or 'Nothing' for infinite. By default, the limit is 80 characters. -- -- @since 0.10.2.0 setWidth :: Maybe Int -> FormatOptions -> FormatOptions setWidth w opts = opts { formatOptionsWidth = w } -- | Control when and whether tags are rendered to output. -- -- @since 0.1.1.0 setTagRendering :: (Event -> TagRender) -> FormatOptions -> FormatOptions setTagRendering f opts = opts { formatOptionsRenderTags = f } encode :: MonadResource m => ConduitM Event o m ByteString encode = encodeWith defaultFormatOptions -- | -- @since 0.10.2.0 encodeWith :: MonadResource m => FormatOptions -> ConduitM Event o m ByteString encodeWith opts = runEmitter opts alloc close where alloc emitter = do fbuf <- mallocForeignPtrBytes bufferSize withForeignPtr fbuf c_buffer_init withForeignPtr fbuf $ c_my_emitter_set_output emitter return fbuf close _ fbuf = withForeignPtr fbuf $ \b -> do ptr' <- c_get_buffer_buff b len <- c_get_buffer_used b fptr <- newForeignPtr_ $ castPtr ptr' return $ B.fromForeignPtr fptr 0 $ fromIntegral len encodeFile :: MonadResource m => FilePath -> ConduitM Event o m () encodeFile = encodeFileWith defaultFormatOptions -- | -- @since 0.10.2.0 encodeFileWith :: MonadResource m => FormatOptions -> FilePath -> ConduitM Event o m () encodeFileWith opts filePath = bracketP getFile cleanup $ \file -> runEmitter opts (alloc file) (\u _ -> return u) where cleanup file = do res <- c_fclose file when (res /= 0) $ throwIO $ YamlException $ "could not close file: " ++ filePath getFile = do #if WINDOWS && __GLASGOW_HASKELL__ >= 806 -- See: https://github.com/snoyberg/yaml/issues/178#issuecomment-550180027 removeFile filePath `Control.Exception.catch` (\(_ :: Control.Exception.IOException) -> pure ()) #endif file <- openFile filePath write_flags "w" if file == nullPtr then throwIO $ YamlException $ "could not open file for write: " ++ filePath else return file alloc file emitter = c_yaml_emitter_set_output_file emitter file runEmitter :: MonadResource m => FormatOptions -> (Emitter -> IO a) -- ^ alloc -> (() -> a -> IO b) -- ^ close -> ConduitM Event o m b runEmitter opts allocI closeI = bracketP alloc cleanup go where alloc = mask_ $ do emitter <- mallocBytes emitterSize res <- c_yaml_emitter_initialize emitter when (res == 0) $ throwIO $ YamlException "c_yaml_emitter_initialize failed" #ifndef __NO_UNICODE__ c_yaml_emitter_set_unicode emitter 1 #endif c_yaml_emitter_set_width emitter $ case formatOptionsWidth opts of Nothing -> -1 --infinite Just width -> fromIntegral width a <- allocI emitter return (emitter, a) cleanup (emitter, _) = do c_yaml_emitter_delete emitter free emitter go (emitter, a) = loop where loop = await >>= maybe (close ()) push push e = do _ <- liftIO $ toEventRaw opts e $ c_yaml_emitter_emit emitter loop close u = liftIO $ closeI u a -- | The pointer position data YamlMark = YamlMark { yamlIndex :: Int, yamlLine :: Int, yamlColumn :: Int } deriving Show data YamlException = YamlException String -- | problem, context, index, position line, position column | YamlParseException { yamlProblem :: String, yamlContext :: String, yamlProblemMark :: YamlMark } deriving (Show, Typeable) instance Exception YamlException libyaml-0.1.4/c/helper.c0000644000000000000000000000630114370231742013203 0ustar0000000000000000#include #include #include #include "helper.h" void buffer_init(buffer_t *buffer) { buffer->buff = 0; buffer->size = buffer->used = 0; } int buffer_append(void *ext, unsigned char *str, size_t size) { buffer_t *b = ext; int new_size, new_used; unsigned char *tmp; new_used = b->used + size; for (new_size = b->size ? b->size : 8; new_size < new_used; new_size *= 2); if (new_size != b->size) { tmp = realloc(b->buff, new_size); if (!tmp) return 0; b->buff = tmp; b->size = new_size; } memcpy(b->buff + b->used, str, size); b->used = new_used; return 1; } unsigned char * get_buffer_buff(buffer_t *b) { return b->buff; } unsigned int get_buffer_used(buffer_t *b) { return b->used; } void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b) { yaml_emitter_set_output(e, buffer_append, b); } char const * get_parser_error_problem(yaml_parser_t *p) { return p->problem; } char const * get_parser_error_context(yaml_parser_t *p) { return p->context; } const yaml_mark_t * get_parser_error_mark(yaml_parser_t *p) { return &p->problem_mark; } 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 (e, 0, 0, 0, 1); } int get_event_type(yaml_event_t *e) { return e->type; } unsigned char * get_scalar_value(yaml_event_t *e) { return e->data.scalar.value; } 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 = (unsigned char *) ""; return s; } int get_scalar_style(yaml_event_t *e) { 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; } int get_sequence_start_style(yaml_event_t *e) { return e->data.sequence_start.style; } unsigned char * get_sequence_start_tag(yaml_event_t *e) { unsigned char *s = e->data.sequence_start.tag; if (!s) s = (unsigned char *) ""; return s; } unsigned char * get_mapping_start_anchor(yaml_event_t *e) { return e->data.mapping_start.anchor; } int get_mapping_start_style(yaml_event_t *e) { return e->data.mapping_start.style; } unsigned char * get_mapping_start_tag(yaml_event_t *e) { unsigned char *s = e->data.mapping_start.tag; if (!s) s = (unsigned char *) ""; return s; } unsigned char * get_alias_anchor(yaml_event_t *e) { return e->data.alias.anchor; } const yaml_mark_t * get_start_mark(yaml_event_t *e) { return &e->start_mark; } const yaml_mark_t * get_end_mark(yaml_event_t *e) { return &e->end_mark; } unsigned int get_mark_index(yaml_mark_t *m) { return m->index; } unsigned int get_mark_line(yaml_mark_t *m) { return m->line; } unsigned int get_mark_column(yaml_mark_t *m) { return m->column; } 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); return 1; } int fclose_helper(FILE *file) { if (! file) return 0; return fclose(file); } libyaml-0.1.4/include/helper.h0000644000000000000000000000251214370231742014411 0ustar0000000000000000#ifndef __HELPER_H__ #define __HELPER_H__ #include typedef struct buffer_s { unsigned char *buff; unsigned int size, used; } buffer_t; void buffer_init(buffer_t *buffer); int buffer_append(void *ext, unsigned char *str, size_t size); unsigned char * get_buffer_buff(buffer_t *b); unsigned int get_buffer_used(buffer_t *b); void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b); char const * get_parser_error_problem(yaml_parser_t *p); char const * get_parser_error_context(yaml_parser_t *p); unsigned int get_parser_error_offset(yaml_parser_t *p); 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 char * get_sequence_start_tag(yaml_event_t *e); unsigned char * get_mapping_start_tag(yaml_event_t *e); int get_scalar_style(yaml_event_t *e); int get_sequence_start_style(yaml_event_t *e); int get_mapping_start_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__ */ libyaml-0.1.4/README.md0000644000000000000000000000035214370231742012615 0ustar0000000000000000# libyaml This package provides a haskell wrapper over the [libyaml C library version 0.2.2 by Kirill Simonov](https://github.com/yaml/libyaml). It contains the C source so you don't need to worry about any non-Haskell dependencies. libyaml-0.1.4/ChangeLog.md0000644000000000000000000000115014574746227013523 0ustar0000000000000000# Changelog for libyaml ## 0.1.4 * Use libyaml-clib for the cbits * Use pkg-config to link to system yaml ## 0.1.3 * Correct signature for `fclose` ## 0.1.2 * Upgrade `libyaml` to 0.2.2 ## 0.1.1.1 * Work around GHC 8.6.5 issue on Windows preventing truncated files. [#178](https://github.com/snoyberg/yaml/issues/178) ## 0.1.1.0 * Add options to `FormatOptions` to govern when tags rendered explicitly and when they are left implicit. [#165](https://github.com/snoyberg/yaml/issues/165) ## 0.1.0.0 * Split `libyaml` into a separate package from `yaml`. This split occurred at `yaml` version 0.10.4.0. libyaml-0.1.4/LICENSE0000644000000000000000000000253014370231742012343 0ustar0000000000000000The following license covers this documentation, and the source code, except where otherwise indicated. Copyright 2008, Michael Snoyman. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. libyaml-0.1.4/Setup.hs0000644000000000000000000000005614370231742012773 0ustar0000000000000000import Distribution.Simple main = defaultMain libyaml-0.1.4/libyaml.cabal0000644000000000000000000000331714574750414013767 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: libyaml version: 0.1.4 synopsis: Low-level, streaming YAML interface. description: README and API documentation are available at category: Text stability: stable homepage: https://github.com/snoyberg/yaml#readme bug-reports: https://github.com/snoyberg/yaml/issues author: Michael Snoyman , Anton Ageev ,Kirill Simonov maintainer: Michael Snoyman license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: include/helper.h README.md ChangeLog.md source-repository head type: git location: https://github.com/snoyberg/yaml flag no-unicode description: Don't enable unicode output. Instead, unicode characters will be escaped. manual: False default: False flag system-libyaml description: Use the system-wide libyaml instead of the bundled copy manual: False default: False library exposed-modules: Text.Libyaml other-modules: Paths_libyaml hs-source-dirs: src ghc-options: -Wall include-dirs: include c-sources: c/helper.c build-depends: base >=4.14 && <5 , bytestring >=0.9.1.4 , conduit >=1.2.8 && <1.4 , resourcet >=0.3 && <1.4 default-language: Haskell2010 if flag(no-unicode) cpp-options: -D__NO_UNICODE__ if !(flag(system-libyaml)) build-depends: libyaml-clib else pkgconfig-depends: yaml-0.1 if os(windows) cpp-options: -DWINDOWS build-depends: directory