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