/
Libyaml.hs
721 lines (627 loc) · 24.3 KB
/
Libyaml.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
-- | Low-level, streaming YAML interface. For a higher-level interface, see
-- "Data.Yaml".
module Text.Libyaml
( -- * The event stream
Event (..)
, Style (..)
, SequenceStyle (..)
, MappingStyle (..)
, Tag (..)
, AnchorName
, Anchor
-- * Encoding and decoding
, encode
, encodeWith
, decode
, encodeFile
, decodeFile
, encodeFileWith
, FormatOptions
, defaultFormatOptions
, setWidth
-- * 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
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)
-- | 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)
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 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 ()
foreign import ccall unsafe "fclose_helper"
c_fclose_helper :: File -> IO ()
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_index"
c_get_parser_error_index :: Parser -> IO CULong
foreign import ccall unsafe "get_parser_error_line"
c_get_parser_error_line :: Parser -> IO CULong
foreign import ccall unsafe "get_parser_error_column"
c_get_parser_error_column :: Parser -> IO CULong
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_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 Event)
getEvent er = do
et <- c_get_event_type er
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
-- 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 :: Event -> (EventRaw -> IO a) -> IO a
toEventRaw 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 (pi, style) =
case style0 of
PlainNoTag -> (1, Plain)
x -> (0, x)
style' = toEnum $ fromEnum style
tagP = castPtr tag'
qi = if null thetag' then 1 else 0
case anchor of
Nothing ->
c_yaml_scalar_event_initialize
er
nullPtr -- anchor
tagP -- tag
value' -- value
len' -- length
pi -- plain_implicit
qi -- 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
qi -- 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
1
(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
1
(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
1
(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
1
(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
newtype ToEventRawException = ToEventRawException CInt
deriving (Show, Typeable)
instance Exception ToEventRawException
decode :: MonadResource m => B.ByteString -> ConduitM i Event m ()
decode bs | B8.null bs = return ()
decode 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
decodeFile :: MonadResource m => FilePath -> ConduitM i Event m ()
decodeFile 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
c_fclose_helper file'
c_yaml_parser_delete ptr
free ptr
runParser :: MonadResource m => Parser -> ConduitM i Event 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 Event))
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
index <- c_get_parser_error_index parser
line <- c_get_parser_error_line parser
column <- c_get_parser_error_column parser
let problemMark = YamlMark (fromIntegral index) (fromIntegral line) (fromIntegral column)
return $ Left $ YamlParseException problem context problemMark
else Right <$> getEvent er
-- | Contains options relating to the formatting (indendation, width) of the YAML output.
--
-- @since 0.10.2.0
data FormatOptions = FormatOptions
{ formatOptionsWidth :: Maybe Int
}
-- |
-- @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
}
-- | 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 }
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 c_fclose $ \file -> runEmitter opts (alloc file) (\u _ -> return u)
where
getFile = do
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 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