1{-# LANGUAGE EmptyDataDecls #-} 2{-# LANGUAGE ForeignFunctionInterface #-} 3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE MultiParamTypeClasses #-} 7{-# LANGUAGE RankNTypes #-} 8{-# LANGUAGE CPP #-} 9{-# LANGUAGE TypeFamilies #-} 10{-# LANGUAGE ScopedTypeVariables #-} 11 12-- | Low-level, streaming YAML interface. For a higher-level interface, see 13-- "Data.Yaml". 14module Text.Libyaml 15 ( -- * The event stream 16 MarkedEvent(..) 17 , Event (..) 18 , Style (..) 19 , SequenceStyle (..) 20 , MappingStyle (..) 21 , Tag (..) 22 , AnchorName 23 , Anchor 24 -- * Encoding and decoding 25 , encode 26 , encodeWith 27 , decode 28 , decodeMarked 29 , encodeFile 30 , decodeFile 31 , decodeFileMarked 32 , encodeFileWith 33 , FormatOptions 34 , defaultFormatOptions 35 , setWidth 36 , setTagRendering 37 , renderScalarTags 38 , renderAllTags 39 , renderNoTags 40 , renderUriTags 41 -- * Error handling 42 , YamlException (..) 43 , YamlMark (..) 44 ) where 45 46import Prelude hiding (pi) 47 48import Data.Bits ((.|.)) 49import Foreign.C 50import Foreign.Ptr 51import Foreign.ForeignPtr 52#if MIN_VERSION_base(4,7,0) 53import Foreign.ForeignPtr.Unsafe 54#endif 55import Foreign.Marshal.Alloc 56import qualified System.Posix.Internals as Posix 57 58#if !MIN_VERSION_base(4,8,0) 59import Control.Applicative 60#endif 61import Control.Exception (mask_, throwIO, Exception, finally) 62import Control.Monad 63import Control.Monad.IO.Class 64import Control.Monad.Trans.Resource 65import Data.Conduit hiding (Source, Sink, Conduit) 66import Data.Data 67 68import Data.ByteString (ByteString, packCString, packCStringLen) 69import qualified Data.ByteString.Char8 as B8 70import qualified Data.ByteString.Internal as B 71import qualified Data.ByteString.Unsafe as BU 72 73#if WINDOWS && __GLASGOW_HASKELL__ >= 806 74import System.Directory (removeFile) 75import qualified Control.Exception 76#endif 77 78data Event = 79 EventStreamStart 80 | EventStreamEnd 81 | EventDocumentStart 82 | EventDocumentEnd 83 | EventAlias !AnchorName 84 | EventScalar !ByteString !Tag !Style !Anchor 85 | EventSequenceStart !Tag !SequenceStyle !Anchor 86 | EventSequenceEnd 87 | EventMappingStart !Tag !MappingStyle !Anchor 88 | EventMappingEnd 89 deriving (Show, Eq) 90 91-- | Event with start and end marks. 92-- 93-- @since 0.10.4.0 94data MarkedEvent = MarkedEvent 95 { yamlEvent :: Event 96 , yamlStartMark :: YamlMark 97 , yamlEndMark :: YamlMark 98 } 99 100-- | Style for scalars - e.g. quoted / folded 101-- 102data Style = Any 103 | Plain 104 | SingleQuoted 105 | DoubleQuoted 106 | Literal 107 | Folded 108 | PlainNoTag 109 deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable) 110 111-- | Style for sequences - e.g. block or flow 112-- 113-- @since 0.9.0 114data SequenceStyle = AnySequence | BlockSequence | FlowSequence 115 deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable) 116 117-- | Style for mappings - e.g. block or flow 118-- 119-- @since 0.9.0 120data MappingStyle = AnyMapping | BlockMapping | FlowMapping 121 deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable) 122 123data Tag = StrTag 124 | FloatTag 125 | NullTag 126 | BoolTag 127 | SetTag 128 | IntTag 129 | SeqTag 130 | MapTag 131 | UriTag String 132 | NoTag 133 deriving (Show, Eq, Read, Data, Typeable) 134 135tagSuppressed :: Tag -> Bool 136tagSuppressed (NoTag) = True 137tagSuppressed (UriTag "") = True 138tagSuppressed _ = False 139 140type AnchorName = String 141type Anchor = Maybe AnchorName 142 143tagToString :: Tag -> String 144tagToString StrTag = "tag:yaml.org,2002:str" 145tagToString FloatTag = "tag:yaml.org,2002:float" 146tagToString NullTag = "tag:yaml.org,2002:null" 147tagToString BoolTag = "tag:yaml.org,2002:bool" 148tagToString SetTag = "tag:yaml.org,2002:set" 149tagToString IntTag = "tag:yaml.org,2002:int" 150tagToString SeqTag = "tag:yaml.org,2002:seq" 151tagToString MapTag = "tag:yaml.org,2002:map" 152tagToString (UriTag s) = s 153tagToString NoTag = "" 154 155bsToTag :: ByteString -> Tag 156bsToTag = stringToTag . B8.unpack 157 158stringToTag :: String -> Tag 159stringToTag "tag:yaml.org,2002:str" = StrTag 160stringToTag "tag:yaml.org,2002:float" = FloatTag 161stringToTag "tag:yaml.org,2002:null" = NullTag 162stringToTag "tag:yaml.org,2002:bool" = BoolTag 163stringToTag "tag:yaml.org,2002:set" = SetTag 164stringToTag "tag:yaml.org,2002:int" = IntTag 165stringToTag "tag:yaml.org,2002:seq" = SeqTag 166stringToTag "tag:yaml.org,2002:map" = MapTag 167stringToTag "" = NoTag 168stringToTag s = UriTag s 169 170data ParserStruct 171type Parser = Ptr ParserStruct 172parserSize :: Int 173parserSize = 480 174 175data EventRawStruct 176type EventRaw = Ptr EventRawStruct 177eventSize :: Int 178eventSize = 104 179 180foreign import ccall unsafe "yaml_parser_initialize" 181 c_yaml_parser_initialize :: Parser -> IO CInt 182 183foreign import ccall unsafe "yaml_parser_delete" 184 c_yaml_parser_delete :: Parser -> IO () 185 186foreign import ccall unsafe "yaml_parser_set_input_string" 187 c_yaml_parser_set_input_string :: Parser 188 -> Ptr CUChar 189 -> CULong 190 -> IO () 191 192foreign import ccall unsafe "yaml_parser_set_input_file" 193 c_yaml_parser_set_input_file :: Parser 194 -> File 195 -> IO () 196 197data MarkRawStruct 198type MarkRaw = Ptr MarkRawStruct 199 200foreign import ccall unsafe "get_mark_index" 201 c_get_mark_index :: MarkRaw -> IO CULong 202 203foreign import ccall unsafe "get_mark_line" 204 c_get_mark_line :: MarkRaw -> IO CULong 205 206foreign import ccall unsafe "get_mark_column" 207 c_get_mark_column :: MarkRaw -> IO CULong 208 209getMark :: MarkRaw -> IO YamlMark 210getMark m = YamlMark 211 <$> (fromIntegral <$> c_get_mark_index m) 212 <*> (fromIntegral <$> c_get_mark_line m) 213 <*> (fromIntegral <$> c_get_mark_column m) 214 215data FileStruct 216type File = Ptr FileStruct 217 218#ifdef WINDOWS 219foreign import ccall unsafe "_fdopen" 220#else 221foreign import ccall unsafe "fdopen" 222#endif 223 c_fdopen :: CInt 224 -> Ptr CChar 225 -> IO File 226foreign import ccall unsafe "fclose" 227 c_fclose :: File 228 -> IO () 229 230foreign import ccall unsafe "fclose_helper" 231 c_fclose_helper :: File -> IO () 232 233foreign import ccall unsafe "yaml_parser_parse" 234 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt 235 236foreign import ccall unsafe "yaml_event_delete" 237 c_yaml_event_delete :: EventRaw -> IO () 238 239foreign import ccall "get_parser_error_problem" 240 c_get_parser_error_problem :: Parser -> IO (Ptr CUChar) 241 242foreign import ccall "get_parser_error_context" 243 c_get_parser_error_context :: Parser -> IO (Ptr CUChar) 244 245foreign import ccall unsafe "get_parser_error_mark" 246 c_get_parser_error_mark :: Parser -> IO MarkRaw 247 248makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String 249makeString f a = do 250 cchar <- castPtr `liftM` f a 251 if cchar == nullPtr 252 then return "" 253 else liftIO $ peekCString cchar 254 255data EventType = YamlNoEvent 256 | YamlStreamStartEvent 257 | YamlStreamEndEvent 258 | YamlDocumentStartEvent 259 | YamlDocumentEndEvent 260 | YamlAliasEvent 261 | YamlScalarEvent 262 | YamlSequenceStartEvent 263 | YamlSequenceEndEvent 264 | YamlMappingStartEvent 265 | YamlMappingEndEvent 266 deriving (Enum,Show) 267 268foreign import ccall unsafe "get_event_type" 269 c_get_event_type :: EventRaw -> IO CInt 270 271foreign import ccall unsafe "get_start_mark" 272 c_get_start_mark :: EventRaw -> IO MarkRaw 273 274foreign import ccall unsafe "get_end_mark" 275 c_get_end_mark :: EventRaw -> IO MarkRaw 276 277foreign import ccall unsafe "get_scalar_value" 278 c_get_scalar_value :: EventRaw -> IO (Ptr CUChar) 279 280foreign import ccall unsafe "get_scalar_length" 281 c_get_scalar_length :: EventRaw -> IO CULong 282 283foreign import ccall unsafe "get_scalar_tag" 284 c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar) 285 286foreign import ccall unsafe "get_scalar_style" 287 c_get_scalar_style :: EventRaw -> IO CInt 288 289foreign import ccall unsafe "get_scalar_anchor" 290 c_get_scalar_anchor :: EventRaw -> IO CString 291 292foreign import ccall unsafe "get_sequence_start_anchor" 293 c_get_sequence_start_anchor :: EventRaw -> IO CString 294 295foreign import ccall unsafe "get_sequence_start_style" 296 c_get_sequence_start_style :: EventRaw -> IO CInt 297 298foreign import ccall unsafe "get_sequence_start_tag" 299 c_get_sequence_start_tag :: EventRaw -> IO (Ptr CUChar) 300 301foreign import ccall unsafe "get_mapping_start_anchor" 302 c_get_mapping_start_anchor :: EventRaw -> IO CString 303 304foreign import ccall unsafe "get_mapping_start_style" 305 c_get_mapping_start_style :: EventRaw -> IO CInt 306 307foreign import ccall unsafe "get_mapping_start_tag" 308 c_get_mapping_start_tag :: EventRaw -> IO (Ptr CUChar) 309 310foreign import ccall unsafe "get_alias_anchor" 311 c_get_alias_anchor :: EventRaw -> IO CString 312 313readAnchor :: (EventRaw -> IO CString) -> EventRaw -> IO Anchor 314readAnchor getAnchor er = do 315 yanchor <- getAnchor er 316 if yanchor == nullPtr 317 then return Nothing 318 else Just <$> peekCString yanchor 319 320readStyle :: (Enum a) => (EventRaw -> IO CInt) -> EventRaw -> IO a 321readStyle getStyle er = toEnum . fromEnum <$> getStyle er 322 323readTag :: (EventRaw -> IO (Ptr CUChar)) -> EventRaw -> IO Tag 324readTag getTag er = bsToTag <$> (getTag er >>= packCString . castPtr) 325 326getEvent :: EventRaw -> IO (Maybe MarkedEvent) 327getEvent er = do 328 et <- c_get_event_type er 329 startMark <- c_get_start_mark er >>= getMark 330 endMark <- c_get_end_mark er >>= getMark 331 event <- case toEnum $ fromEnum et of 332 YamlNoEvent -> return Nothing 333 YamlStreamStartEvent -> return $ Just EventStreamStart 334 YamlStreamEndEvent -> return $ Just EventStreamEnd 335 YamlDocumentStartEvent -> return $ Just EventDocumentStart 336 YamlDocumentEndEvent -> return $ Just EventDocumentEnd 337 YamlAliasEvent -> do 338 yanchor <- c_get_alias_anchor er 339 anchor <- if yanchor == nullPtr 340 then error "got YamlAliasEvent with empty anchor" 341 else peekCString yanchor 342 return $ Just $ EventAlias anchor 343 YamlScalarEvent -> do 344 yvalue <- c_get_scalar_value er 345 ylen <- c_get_scalar_length er 346 let yvalue' = castPtr yvalue 347 let ylen' = fromEnum ylen 348 bs <- packCStringLen (yvalue', ylen') 349 tag <- readTag c_get_scalar_tag er 350 style <- readStyle c_get_scalar_style er 351 anchor <- readAnchor c_get_scalar_anchor er 352 return $ Just $ EventScalar bs tag style anchor 353 YamlSequenceStartEvent -> do 354 tag <- readTag c_get_sequence_start_tag er 355 style <- readStyle c_get_sequence_start_style er 356 anchor <- readAnchor c_get_sequence_start_anchor er 357 return $ Just $ EventSequenceStart tag style anchor 358 YamlSequenceEndEvent -> return $ Just EventSequenceEnd 359 YamlMappingStartEvent -> do 360 tag <- readTag c_get_mapping_start_tag er 361 style <- readStyle c_get_mapping_start_style er 362 anchor <- readAnchor c_get_mapping_start_anchor er 363 return $ Just $ EventMappingStart tag style anchor 364 YamlMappingEndEvent -> return $ Just EventMappingEnd 365 return $ (\e -> MarkedEvent e startMark endMark) <$> event 366 367-- Emitter 368 369data EmitterStruct 370type Emitter = Ptr EmitterStruct 371emitterSize :: Int 372emitterSize = 432 373 374foreign import ccall unsafe "yaml_emitter_initialize" 375 c_yaml_emitter_initialize :: Emitter -> IO CInt 376 377foreign import ccall unsafe "yaml_emitter_delete" 378 c_yaml_emitter_delete :: Emitter -> IO () 379 380data BufferStruct 381type Buffer = Ptr BufferStruct 382bufferSize :: Int 383bufferSize = 16 384 385foreign import ccall unsafe "buffer_init" 386 c_buffer_init :: Buffer -> IO () 387 388foreign import ccall unsafe "get_buffer_buff" 389 c_get_buffer_buff :: Buffer -> IO (Ptr CUChar) 390 391foreign import ccall unsafe "get_buffer_used" 392 c_get_buffer_used :: Buffer -> IO CULong 393 394foreign import ccall unsafe "my_emitter_set_output" 395 c_my_emitter_set_output :: Emitter -> Buffer -> IO () 396 397#ifndef __NO_UNICODE__ 398foreign import ccall unsafe "yaml_emitter_set_unicode" 399 c_yaml_emitter_set_unicode :: Emitter -> CInt -> IO () 400#endif 401 402foreign import ccall unsafe "yaml_emitter_set_output_file" 403 c_yaml_emitter_set_output_file :: Emitter -> File -> IO () 404 405foreign import ccall unsafe "yaml_emitter_set_width" 406 c_yaml_emitter_set_width :: Emitter -> CInt -> IO () 407 408foreign import ccall unsafe "yaml_emitter_emit" 409 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt 410 411foreign import ccall unsafe "yaml_stream_start_event_initialize" 412 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt 413 414foreign import ccall unsafe "yaml_stream_end_event_initialize" 415 c_yaml_stream_end_event_initialize :: EventRaw -> IO CInt 416 417foreign import ccall unsafe "yaml_scalar_event_initialize" 418 c_yaml_scalar_event_initialize 419 :: EventRaw 420 -> Ptr CUChar -- anchor 421 -> Ptr CUChar -- tag 422 -> Ptr CUChar -- value 423 -> CInt -- length 424 -> CInt -- plain_implicit 425 -> CInt -- quoted_implicit 426 -> CInt -- style 427 -> IO CInt 428 429foreign import ccall unsafe "simple_document_start" 430 c_simple_document_start :: EventRaw -> IO CInt 431 432foreign import ccall unsafe "yaml_document_end_event_initialize" 433 c_yaml_document_end_event_initialize :: EventRaw -> CInt -> IO CInt 434 435foreign import ccall unsafe "yaml_sequence_start_event_initialize" 436 c_yaml_sequence_start_event_initialize 437 :: EventRaw 438 -> Ptr CUChar 439 -> Ptr CUChar 440 -> CInt 441 -> CInt 442 -> IO CInt 443 444foreign import ccall unsafe "yaml_sequence_end_event_initialize" 445 c_yaml_sequence_end_event_initialize :: EventRaw -> IO CInt 446 447foreign import ccall unsafe "yaml_mapping_start_event_initialize" 448 c_yaml_mapping_start_event_initialize 449 :: EventRaw 450 -> Ptr CUChar 451 -> Ptr CUChar 452 -> CInt 453 -> CInt 454 -> IO CInt 455 456foreign import ccall unsafe "yaml_mapping_end_event_initialize" 457 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt 458 459foreign import ccall unsafe "yaml_alias_event_initialize" 460 c_yaml_alias_event_initialize 461 :: EventRaw 462 -> Ptr CUChar 463 -> IO CInt 464 465toEventRaw :: FormatOptions -> Event -> (EventRaw -> IO a) -> IO a 466toEventRaw opts e f = allocaBytes eventSize $ \er -> do 467 ret <- case e of 468 EventStreamStart -> 469 c_yaml_stream_start_event_initialize 470 er 471 0 -- YAML_ANY_ENCODING 472 EventStreamEnd -> 473 c_yaml_stream_end_event_initialize er 474 EventDocumentStart -> 475 c_simple_document_start er 476 EventDocumentEnd -> 477 c_yaml_document_end_event_initialize er 1 478 EventScalar bs thetag style0 anchor -> do 479 BU.unsafeUseAsCStringLen bs $ \(value, len) -> do 480 let value' = castPtr value :: Ptr CUChar 481 len' = fromIntegral len :: CInt 482 let thetag' = tagToString thetag 483 withCString thetag' $ \tag' -> do 484 let pi0 = tagsImplicit e 485 (pi, style) = 486 case style0 of 487 PlainNoTag -> (1, Plain) 488 x -> (pi0, x) 489 style' = toEnum $ fromEnum style 490 tagP = castPtr tag' 491 case anchor of 492 Nothing -> 493 c_yaml_scalar_event_initialize 494 er 495 nullPtr -- anchor 496 tagP -- tag 497 value' -- value 498 len' -- length 499 pi -- plain_implicit 500 pi -- quoted_implicit 501 style' -- style 502 Just anchor' -> 503 withCString anchor' $ \anchorP' -> do 504 let anchorP = castPtr anchorP' 505 c_yaml_scalar_event_initialize 506 er 507 anchorP -- anchor 508 tagP -- tag 509 value' -- value 510 len' -- length 511 0 -- plain_implicit 512 pi -- quoted_implicit 513 style' -- style 514 EventSequenceStart tag style Nothing -> 515 withCString (tagToString tag) $ \tag' -> do 516 let tagP = castPtr tag' 517 c_yaml_sequence_start_event_initialize 518 er 519 nullPtr 520 tagP 521 (tagsImplicit e) 522 (toEnum $ fromEnum style) 523 EventSequenceStart tag style (Just anchor) -> 524 withCString (tagToString tag) $ \tag' -> do 525 let tagP = castPtr tag' 526 withCString anchor $ \anchor' -> do 527 let anchorP = castPtr anchor' 528 c_yaml_sequence_start_event_initialize 529 er 530 anchorP 531 tagP 532 (tagsImplicit e) 533 (toEnum $ fromEnum style) 534 EventSequenceEnd -> 535 c_yaml_sequence_end_event_initialize er 536 EventMappingStart tag style Nothing -> 537 withCString (tagToString tag) $ \tag' -> do 538 let tagP = castPtr tag' 539 c_yaml_mapping_start_event_initialize 540 er 541 nullPtr 542 tagP 543 (tagsImplicit e) 544 (toEnum $ fromEnum style) 545 EventMappingStart tag style (Just anchor) -> 546 withCString (tagToString tag) $ \tag' -> do 547 withCString anchor $ \anchor' -> do 548 let tagP = castPtr tag' 549 let anchorP = castPtr anchor' 550 c_yaml_mapping_start_event_initialize 551 er 552 anchorP 553 tagP 554 (tagsImplicit e) 555 (toEnum $ fromEnum style) 556 EventMappingEnd -> 557 c_yaml_mapping_end_event_initialize er 558 EventAlias anchor -> 559 withCString anchor $ \anchorP' -> do 560 let anchorP = castPtr anchorP' 561 c_yaml_alias_event_initialize 562 er 563 anchorP 564 unless (ret == 1) $ throwIO $ ToEventRawException ret 565 f er 566 where 567 tagsImplicit (EventScalar _ t _ _) | tagSuppressed t = 1 568 tagsImplicit (EventMappingStart t _ _) | tagSuppressed t = 1 569 tagsImplicit (EventSequenceStart t _ _) | tagSuppressed t = 1 570 tagsImplicit evt = toImplicitParam $ formatOptionsRenderTags opts evt 571 572newtype ToEventRawException = ToEventRawException CInt 573 deriving (Show, Typeable) 574instance Exception ToEventRawException 575 576-- | Create a conduit that yields events from a bytestring. 577decode :: MonadResource m => B.ByteString -> ConduitM i Event m () 578decode = mapOutput yamlEvent . decodeMarked 579 580-- | Create a conduit that yields marked events from a bytestring. 581-- 582-- This conduit will yield identical events to that of "decode", but also 583-- includes start and end marks for each event. 584-- 585-- @since 0.10.4.0 586decodeMarked :: MonadResource m => B.ByteString -> ConduitM i MarkedEvent m () 587decodeMarked bs | B8.null bs = return () 588decodeMarked bs = 589 bracketP alloc cleanup (runParser . fst) 590 where 591 alloc = mask_ $ do 592 ptr <- mallocBytes parserSize 593 res <- c_yaml_parser_initialize ptr 594 if res == 0 595 then do 596 c_yaml_parser_delete ptr 597 free ptr 598 throwIO $ YamlException "Yaml out of memory" 599 else do 600 let (bsfptr, offset, len) = B.toForeignPtr bs 601 let bsptrOrig = unsafeForeignPtrToPtr bsfptr 602 let bsptr = castPtr bsptrOrig `plusPtr` offset 603 c_yaml_parser_set_input_string ptr bsptr (fromIntegral len) 604 return (ptr, bsfptr) 605 cleanup (ptr, bsfptr) = do 606 touchForeignPtr bsfptr 607 c_yaml_parser_delete ptr 608 free ptr 609 610-- XXX copied from GHC.IO.FD 611std_flags, read_flags, output_flags, write_flags :: CInt 612std_flags = Posix.o_NOCTTY 613output_flags = std_flags .|. Posix.o_CREAT .|. Posix.o_TRUNC 614read_flags = std_flags .|. Posix.o_RDONLY 615write_flags = output_flags .|. Posix.o_WRONLY 616 617-- | Open a C FILE* from a file path, using internal GHC API to work correctly 618-- on all platforms, even on non-ASCII filenames. The opening mode must be 619-- indicated via both 'rawOpenFlags' and 'openMode'. 620openFile :: FilePath -> CInt -> String -> IO File 621openFile file rawOpenFlags openMode = do 622 fd <- liftIO $ Posix.withFilePath file $ \file' -> 623 Posix.c_open file' rawOpenFlags 0o666 624 if fd /= (-1) 625 then withCString openMode $ \openMode' -> c_fdopen fd openMode' 626 else return nullPtr 627 628-- | Creata a conduit that yields events from a file. 629decodeFile :: MonadResource m => FilePath -> ConduitM i Event m () 630decodeFile = mapOutput yamlEvent . decodeFileMarked 631 632-- | Create a conduit that yields marked events from a file. 633-- 634-- This conduit will yield identical events to that of "decodeFile", but also 635-- includes start and end marks for each event. 636-- 637-- @since 0.10.4.0 638decodeFileMarked :: MonadResource m => FilePath -> ConduitM i MarkedEvent m () 639decodeFileMarked file = 640 bracketP alloc cleanup (runParser . fst) 641 where 642 alloc = mask_ $ do 643 ptr <- mallocBytes parserSize 644 res <- c_yaml_parser_initialize ptr 645 if res == 0 646 then do 647 c_yaml_parser_delete ptr 648 free ptr 649 throwIO $ YamlException "Yaml out of memory" 650 else do 651 file' <- openFile file read_flags "r" 652 if file' == nullPtr 653 then do 654 c_yaml_parser_delete ptr 655 free ptr 656 throwIO $ YamlException 657 $ "Yaml file not found: " ++ file 658 else do 659 c_yaml_parser_set_input_file ptr file' 660 return (ptr, file') 661 cleanup (ptr, file') = do 662 c_fclose_helper file' 663 c_yaml_parser_delete ptr 664 free ptr 665 666runParser :: MonadResource m => Parser -> ConduitM i MarkedEvent m () 667runParser parser = do 668 e <- liftIO $ parserParseOne' parser 669 case e of 670 Left err -> liftIO $ throwIO err 671 Right Nothing -> return () 672 Right (Just ev) -> yield ev >> runParser parser 673 674parserParseOne' :: Parser 675 -> IO (Either YamlException (Maybe MarkedEvent)) 676parserParseOne' parser = allocaBytes eventSize $ \er -> do 677 res <- liftIO $ c_yaml_parser_parse parser er 678 flip finally (c_yaml_event_delete er) $ 679 if res == 0 680 then do 681 problem <- makeString c_get_parser_error_problem parser 682 context <- makeString c_get_parser_error_context parser 683 problemMark <- c_get_parser_error_mark parser >>= getMark 684 return $ Left $ YamlParseException problem context problemMark 685 else Right <$> getEvent er 686 687-- | Whether a tag should be rendered explicitly in the output or left 688-- implicit. 689-- 690-- @since 0.1.1.0 691data TagRender = Explicit | Implicit 692 deriving (Enum) 693 694toImplicitParam :: TagRender -> CInt 695toImplicitParam Explicit = 0 696toImplicitParam Implicit = 1 697 698-- | A value for 'formatOptionsRenderTags' that renders no 699-- collection tags but all scalar tags (unless suppressed with styles 700-- 'NoTag or 'PlainNoTag'). 701-- 702-- @since 0.1.1.0 703renderScalarTags :: Event -> TagRender 704renderScalarTags (EventScalar _ _ _ _) = Explicit 705renderScalarTags (EventSequenceStart _ _ _) = Implicit 706renderScalarTags (EventMappingStart _ _ _) = Implicit 707renderScalarTags _ = Implicit 708 709-- | A value for 'formatOptionsRenderTags' that renders all 710-- tags (except 'NoTag' tag and 'PlainNoTag' style). 711-- 712-- @since 0.1.1.0 713renderAllTags :: Event -> TagRender 714renderAllTags _ = Explicit 715 716-- | A value for 'formatOptionsRenderTags' that renders no 717-- tags. 718-- 719-- @since 0.1.1.0 720renderNoTags :: Event -> TagRender 721renderNoTags _ = Implicit 722 723-- | A value for 'formatOptionsRenderCollectionTags' that renders tags 724-- which are instances of 'UriTag' 725-- 726-- @since 0.1.1.0 727renderUriTags :: Event -> TagRender 728renderUriTags (EventScalar _ UriTag{} _ _) = Explicit 729renderUriTags (EventSequenceStart UriTag{} _ _) = Explicit 730renderUriTags (EventMappingStart UriTag{} _ _) = Explicit 731renderUriTags _ = Implicit 732 733-- | Contains options relating to the formatting (indendation, width) of the YAML output. 734-- 735-- @since 0.10.2.0 736data FormatOptions = FormatOptions 737 { formatOptionsWidth :: Maybe Int 738 , formatOptionsRenderTags :: Event -> TagRender 739 } 740 741-- | 742-- @since 0.10.2.0 743defaultFormatOptions :: FormatOptions 744defaultFormatOptions = FormatOptions 745 { 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 746 , formatOptionsRenderTags = renderScalarTags 747 } 748 749-- | Set the maximum number of columns in the YAML output, or 'Nothing' for infinite. By default, the limit is 80 characters. 750-- 751-- @since 0.10.2.0 752setWidth :: Maybe Int -> FormatOptions -> FormatOptions 753setWidth w opts = opts { formatOptionsWidth = w } 754 755-- | Control when and whether tags are rendered to output. 756-- 757-- @since 0.1.1.0 758setTagRendering :: (Event -> TagRender) -> FormatOptions -> FormatOptions 759setTagRendering f opts = opts { formatOptionsRenderTags = f } 760 761encode :: MonadResource m => ConduitM Event o m ByteString 762encode = encodeWith defaultFormatOptions 763 764-- | 765-- @since 0.10.2.0 766encodeWith :: MonadResource m => FormatOptions -> ConduitM Event o m ByteString 767encodeWith opts = 768 runEmitter opts alloc close 769 where 770 alloc emitter = do 771 fbuf <- mallocForeignPtrBytes bufferSize 772 withForeignPtr fbuf c_buffer_init 773 withForeignPtr fbuf $ c_my_emitter_set_output emitter 774 return fbuf 775 close _ fbuf = withForeignPtr fbuf $ \b -> do 776 ptr' <- c_get_buffer_buff b 777 len <- c_get_buffer_used b 778 fptr <- newForeignPtr_ $ castPtr ptr' 779 return $ B.fromForeignPtr fptr 0 $ fromIntegral len 780 781 782encodeFile :: MonadResource m 783 => FilePath 784 -> ConduitM Event o m () 785encodeFile = encodeFileWith defaultFormatOptions 786 787-- | 788-- @since 0.10.2.0 789encodeFileWith :: MonadResource m 790 => FormatOptions 791 -> FilePath 792 -> ConduitM Event o m () 793encodeFileWith opts filePath = 794 bracketP getFile c_fclose $ \file -> runEmitter opts (alloc file) (\u _ -> return u) 795 where 796 getFile = do 797#if WINDOWS && __GLASGOW_HASKELL__ >= 806 798 -- See: https://github.com/snoyberg/yaml/issues/178#issuecomment-550180027 799 removeFile filePath `Control.Exception.catch` 800 (\(_ :: Control.Exception.IOException) -> pure ()) 801#endif 802 file <- openFile filePath write_flags "w" 803 if file == nullPtr 804 then throwIO $ YamlException $ "could not open file for write: " ++ filePath 805 else return file 806 807 alloc file emitter = c_yaml_emitter_set_output_file emitter file 808 809runEmitter :: MonadResource m 810 => FormatOptions 811 -> (Emitter -> IO a) -- ^ alloc 812 -> (() -> a -> IO b) -- ^ close 813 -> ConduitM Event o m b 814runEmitter opts allocI closeI = 815 bracketP alloc cleanup go 816 where 817 alloc = mask_ $ do 818 emitter <- mallocBytes emitterSize 819 res <- c_yaml_emitter_initialize emitter 820 when (res == 0) $ throwIO $ YamlException "c_yaml_emitter_initialize failed" 821#ifndef __NO_UNICODE__ 822 c_yaml_emitter_set_unicode emitter 1 823#endif 824 c_yaml_emitter_set_width emitter $ case formatOptionsWidth opts of 825 Nothing -> -1 --infinite 826 Just width -> fromIntegral width 827 a <- allocI emitter 828 return (emitter, a) 829 cleanup (emitter, _) = do 830 c_yaml_emitter_delete emitter 831 free emitter 832 833 go (emitter, a) = 834 loop 835 where 836 loop = await >>= maybe (close ()) push 837 838 push e = do 839 _ <- liftIO $ toEventRaw opts e $ c_yaml_emitter_emit emitter 840 loop 841 close u = liftIO $ closeI u a 842 843-- | The pointer position 844data YamlMark = YamlMark { yamlIndex :: Int, yamlLine :: Int, yamlColumn :: Int } 845 deriving Show 846 847data YamlException = YamlException String 848 -- | problem, context, index, position line, position column 849 | YamlParseException { yamlProblem :: String, yamlContext :: String, yamlProblemMark :: YamlMark } 850 deriving (Show, Typeable) 851instance Exception YamlException 852