1 ! Copyright (C) 2013 Jon Harper.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.data arrays assocs byte-arrays
4 classes.struct combinators combinators.extras
5 combinators.short-circuit destructors fry generalizations
6 hashtables hashtables.identity io.encodings.string
7 io.encodings.utf8 kernel libc linked-assocs make math
8 math.parser namespaces sequences sets strings yaml.config
9 yaml.conversion yaml.ffi hash-sets.identity ;
12 ERROR: libyaml-parser-error
13 error problem problem_offset
14 problem_value problem_mark context context_mark ;
15 ERROR: libyaml-initialize-error ;
16 ERROR: libyaml-emitter-error error problem ;
18 ERROR: yaml-undefined-anchor anchor anchors ;
19 ERROR: yaml-unexpected-event actual expected ;
20 ERROR: yaml-no-document ;
24 : yaml-initialize-assert-ok ( ? -- )
25 [ libyaml-initialize-error ] unless ;
27 : (libyaml-parser-error) ( parser -- )
36 } cleave [ clone ] 7 napply libyaml-parser-error ;
38 : (libyaml-emitter-error) ( emitter -- )
39 [ error>> ] [ problem>> ] bi [ clone ] bi@ libyaml-emitter-error ;
41 : yaml-parser-assert-ok ( ? parser -- )
42 swap [ drop ] [ (libyaml-parser-error) ] if ;
44 : yaml-emitter-assert-ok ( ? emitter -- )
45 swap [ drop ] [ (libyaml-emitter-error) ] if ;
47 : yaml_parser_parse_asserted ( parser event -- )
48 [ yaml_parser_parse ] [ drop yaml-parser-assert-ok ] 2bi ;
50 : yaml_emitter_emit_asserted ( emitter event -- )
51 [ yaml_emitter_emit ] [ drop yaml-emitter-assert-ok ] 2bi ;
53 TUPLE: yaml-alias anchor ;
54 C: <yaml-alias> yaml-alias
58 : ?register-anchor ( obj event -- obj )
59 dupd anchor>> [ anchors get set-at ] [ drop ] if* ;
61 : assert-anchor-exists ( anchor -- )
62 anchors get 2dup at* nip
63 [ 2drop ] [ yaml-undefined-anchor ] if ;
65 : deref-anchor ( event -- obj )
66 data>> alias>> anchor>>
67 [ assert-anchor-exists ]
70 : event>scalar ( mapping-key? event -- obj )
72 [ swap construct-scalar ]
73 [ ?register-anchor ] bi ;
75 ! TODO simplify this ?!?
76 TUPLE: factor_sequence_start_event_data anchor tag implicit style ;
77 TUPLE: factor_mapping_start_event_data anchor tag implicit style ;
78 TUPLE: factor_event_data sequence_start mapping_start ;
79 TUPLE: factor_yaml_event_t type data start_mark end_mark ;
81 : deep-copy-seq ( data -- data' )
87 } cleave factor_sequence_start_event_data boa ;
89 : deep-copy-map ( data -- data' )
95 } cleave factor_mapping_start_event_data boa ;
97 : deep-copy-data ( event -- data )
98 [ data>> ] [ type>> ] bi {
99 { YAML_SEQUENCE_START_EVENT [ sequence_start>> deep-copy-seq f ] }
100 { YAML_MAPPING_START_EVENT [ mapping_start>> deep-copy-map f swap ] }
101 } case factor_event_data boa ;
103 : deep-copy-event ( event -- event' )
109 } cleave factor_yaml_event_t boa ;
111 : (?scalar-value) ( mapping-key? event -- scalar/event scalar? )
113 { YAML_SCALAR_EVENT [ event>scalar t ] }
114 { YAML_ALIAS_EVENT [ nip deref-anchor t ] }
115 [ drop nip deep-copy-event f ]
117 : ?mapping-key-scalar-value ( event -- scalar/event scalar? ) t swap (?scalar-value) ;
118 : ?scalar-value ( event -- scalar/event scalar? ) f swap (?scalar-value) ;
120 ! Must not reuse the event struct before with-destructors scope ends
121 : next-event ( parser event -- event )
122 [ yaml_parser_parse_asserted ] [ &yaml_event_delete ] bi ;
124 DEFER: parse-sequence
127 : (parse-sequence) ( parser event prev-event -- obj )
128 data>> sequence_start>> [ [ 2drop f ] dip ?register-anchor drop ]
129 [ [ parse-sequence ] [ construct-sequence ] bi* ] [ 2nip ?register-anchor ] 3tri ;
131 : (parse-mapping) ( parser event prev-event -- obj )
132 data>> mapping_start>> [ [ 2drop f ] dip ?register-anchor drop ]
133 [ [ parse-mapping ] [ construct-mapping ] bi* ] [ 2nip ?register-anchor ] 3tri ;
135 : next-complex-value ( parser event prev-event -- obj )
137 { YAML_SEQUENCE_START_EVENT [ (parse-sequence) ] }
138 { YAML_MAPPING_START_EVENT [ (parse-mapping) ] }
141 :: next-value ( parser event -- obj )
142 parser event [ next-event ?scalar-value ] with-destructors
143 [ [ parser event ] dip next-complex-value ] unless ;
145 :: parse-mapping ( parser event -- map )
150 parser event next-event type>>
151 YAML_MAPPING_END_EVENT = [
154 event ?mapping-key-scalar-value
158 [ [ parser event ] dip next-complex-value ] unless
159 parser event next-value swap ,,
164 :: parse-sequence ( parser event -- seq )
169 parser event next-event type>>
170 YAML_SEQUENCE_END_EVENT = [
177 [ [ parser event ] dip next-complex-value ] unless ,
182 : expect-event ( parser event type -- )
184 [ next-event type>> ] dip 2dup =
185 [ 2drop ] [ 1array yaml-unexpected-event ] if
188 GENERIC: (deref-aliases) ( anchors obj -- obj' )
190 M: object (deref-aliases) nip ;
192 M: byte-array (deref-aliases) nip ;
194 M: string (deref-aliases) nip ;
196 M: yaml-alias (deref-aliases) anchor>> of ;
198 M: sequence (deref-aliases)
199 [ (deref-aliases) ] with map! ;
201 M: sets:set (deref-aliases)
202 [ members (deref-aliases) ] [ clear-set ] [ swap union! ] tri ;
204 : assoc-map! ( assoc quot -- assoc' )
205 [ assoc-map ] [ drop clear-assoc ] [ drop swap assoc-union! ] 2tri ; inline
207 M: assoc (deref-aliases)
208 [ [ (deref-aliases) ] bi-curry@ bi ] withd assoc-map! ;
210 : merge-values ( seq -- assoc )
211 reverse [ ] [ assoc-union ] map-reduce ;
212 GENERIC: merge-value ( assoc value -- assoc' )
213 M: sequence merge-value merge-values merge-value ;
214 M: assoc merge-value over assoc-diff assoc-union! ;
215 : pop-at* ( key assoc -- value/f ? )
216 [ at* ] 2keep pick [ delete-at ] [ 2drop ] if ;
218 : ?apply-default-key ( assoc -- obj' )
219 T{ yaml-value } over pop-at* [ nip ] [ drop ] if ;
222 : ?apply-merge-key ( assoc -- assoc' )
223 T{ yaml-merge } over pop-at*
224 [ merge-value ] [ drop ] if ;
225 : scalar-value ( obj -- obj' )
226 dup hashtable? [ ?apply-default-key ] when ;
230 GENERIC: apply-merge-keys ( already-applied-set obj -- obj' )
231 : ?apply-merge-keys ( set obj -- obj' )
232 2dup swap ?adjoin [ apply-merge-keys ] [ nip ] if ;
233 M: sequence apply-merge-keys
234 [ ?apply-merge-keys ] with map! ;
235 M: object apply-merge-keys nip ;
236 M: byte-array apply-merge-keys nip ;
237 M: string apply-merge-keys nip ;
238 M: assoc apply-merge-keys
239 [ [ ?apply-merge-keys ] bi-curry@ bi ] withd assoc-map!
240 merge get [ ?apply-merge-key ] when
241 value get [ ?apply-default-key ] when ;
243 :: parse-yaml-doc ( parser event -- obj )
245 parser event next-value
246 anchors get swap (deref-aliases)
247 merge get value get or [ IHS{ } clone swap ?apply-merge-keys ] when
250 :: ?parse-yaml-doc ( parser event -- obj/f ? )
252 parser event next-event type>> {
253 { YAML_DOCUMENT_START_EVENT [ t ] }
254 { YAML_STREAM_END_EVENT [ f ] }
255 [ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } yaml-unexpected-event ]
258 parser event parse-yaml-doc t
259 parser event YAML_DOCUMENT_END_EVENT expect-event
262 ! registers destructors (use with with-destructors)
263 :: init-parser ( str -- parser event )
264 yaml_parser_t (malloc-struct) &free :> parser
265 parser yaml_parser_initialize yaml-initialize-assert-ok
266 parser &yaml_parser_delete drop
269 [ malloc-byte-array &free ] [ length ] bi :> ( input length )
270 parser input length yaml_parser_set_input_string
272 yaml_event_t (malloc-struct) &free :> event
277 : yaml> ( str -- obj )
280 [ YAML_STREAM_START_EVENT expect-event ]
281 [ ?parse-yaml-doc [ yaml-no-document ] unless ] 2bi
284 : yaml-docs> ( str -- arr )
287 [ YAML_STREAM_START_EVENT expect-event ]
288 [ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi
293 TUPLE: yaml-anchors objects new-objects next-anchor ;
295 : <yaml-anchors> ( -- yaml-anchors )
296 IH{ } clone IH{ } clone 0 yaml-anchors boa ;
298 GENERIC: (replace-aliases) ( yaml-anchors obj -- obj' )
300 : incr-anchor ( yaml-anchors -- current-anchor )
302 [ [ number>string ] [ 1 + ] bi ]
303 [ next-anchor<< ] bi*
306 :: (?replace-aliases) ( yaml-anchors obj -- obj' )
307 yaml-anchors objects>> :> objects
309 [ yaml-anchors incr-anchor dup obj objects set-at ] unless*
312 drop f obj objects set-at
313 yaml-anchors obj (replace-aliases) :> obj'
314 obj obj' yaml-anchors new-objects>> set-at
318 : ?replace-aliases ( yaml-anchors obj -- obj' )
319 dup fixnum? [ nip ] [ (?replace-aliases) ] if ;
321 M: object (replace-aliases) nip ;
323 M: byte-array (replace-aliases) nip ;
325 M: string (replace-aliases) nip ;
327 M: sequence (replace-aliases)
328 [ ?replace-aliases ] with map ;
330 M: sets:set (replace-aliases)
331 [ members (replace-aliases) ] keep set-like ;
333 M: assoc (replace-aliases)
334 swap '[ [ _ swap ?replace-aliases ] bi@ ] assoc-map ;
336 TUPLE: yaml-anchor anchor obj ;
337 C: <yaml-anchor> yaml-anchor
339 GENERIC: (replace-anchors) ( yaml-anchors obj -- obj' )
341 : (get-anchor) ( yaml-anchors obj -- anchor/f )
344 : get-anchor ( yaml-anchors obj -- anchor/f )
345 { [ (get-anchor) ] [ over new-objects>> at (get-anchor) ] } 2|| ;
347 : ?replace-anchors ( yaml-anchors obj -- obj' )
348 [ (replace-anchors) ] [ get-anchor ] 2bi [ swap <yaml-anchor> ] when* ;
350 M: object (replace-anchors) nip ;
352 M: byte-array (replace-anchors) nip ;
354 M: string (replace-anchors) nip ;
356 M: sequence (replace-anchors)
357 [ ?replace-anchors ] with map ;
359 M: sets:set (replace-anchors)
360 [ members ?replace-anchors ] keep set-like ;
362 M: assoc (replace-anchors)
363 swap '[ [ _ swap ?replace-anchors ] bi@ ] assoc-map ;
365 : replace-identities ( obj -- obj' )
366 [ <yaml-anchors> ] dip dupd ?replace-aliases ?replace-anchors ;
368 ! TODO We can also pass some data when registering the write handler,
369 ! use this to have several buffers if it can be interrupted.
370 ! For now, only do operations on strings that are in memory
371 ! so we don't need to be reentrant.
372 SYMBOL: yaml-write-buffer
373 : yaml-write-handler ( -- alien )
375 memory>byte-array yaml-write-buffer get-global
377 ] yaml_write_handler_t ;
379 GENERIC: emit-value ( emitter event anchor obj -- )
381 : emit-object ( emitter event obj -- ) [ f ] dip emit-value ;
383 : scalar-implicit-tag? ( tag str mapping-key? -- plain_implicit quoted_implicit )
385 resolve-plain-scalar = t
388 :: (emit-scalar) ( emitter event anchor obj mapping-key? -- )
390 obj [ yaml-tag ] [ represent-scalar ] bi
391 -1 2over mapping-key? scalar-implicit-tag? YAML_ANY_SCALAR_STYLE
392 yaml_scalar_event_initialize yaml-initialize-assert-ok
393 emitter event yaml_emitter_emit_asserted ;
395 : emit-mapping-key-scalar ( emitter event anchor obj -- ) t (emit-scalar) ;
396 : emit-scalar ( emitter event anchor obj -- ) f (emit-scalar) ;
398 ! strings and special keys are the only things that need special treatment
399 ! because they can have the same representation
400 : emit-mapping-key ( emitter event obj -- )
401 dup { [ string? ] [ yaml-merge? ] [ yaml-value? ] } 1||
402 [ [ f ] dip emit-mapping-key-scalar ] [ emit-object ] if ;
404 M: object emit-value ( emitter event anchor obj -- ) emit-scalar ;
406 M: yaml-anchor emit-value ( emitter event unused obj -- )
407 nip [ anchor>> ] [ obj>> ] bi emit-value ;
409 M:: yaml-alias emit-value ( emitter event unused obj -- )
410 event obj anchor>> yaml_alias_event_initialize yaml-initialize-assert-ok
411 emitter event yaml_emitter_emit_asserted ;
413 :: emit-sequence-start ( emitter event anchor tag implicit -- )
414 event anchor tag implicit YAML_ANY_SEQUENCE_STYLE
415 yaml_sequence_start_event_initialize yaml-initialize-assert-ok
416 emitter event yaml_emitter_emit_asserted ;
418 : emit-sequence-end ( emitter event -- )
419 dup yaml_sequence_end_event_initialize yaml-initialize-assert-ok
420 yaml_emitter_emit_asserted ;
422 : emit-sequence-body ( emitter event seq -- )
423 [ emit-object ] 2with each ;
425 : emit-assoc-body ( emitter event assoc -- )
428 [ emit-object ] bi-curry* 2bi
429 ] withd withd assoc-each ;
431 : emit-linked-assoc-body ( emitter event linked-assoc -- )
432 >alist [ first2 swap associate ] map emit-sequence-body ;
434 : emit-set-body ( emitter event set -- )
435 [ members ] [ cardinality f <array> ] bi zip concat emit-sequence-body ;
437 M: f emit-value ( emitter event anchor f -- ) emit-scalar ;
439 M: string emit-value ( emitter event anchor string -- ) emit-scalar ;
441 M: byte-array emit-value ( emitter event anchor byte-array -- ) emit-scalar ;
443 M: sequence emit-value ( emitter event anchor seq -- )
444 [ drop YAML_SEQ_TAG implicit-tags get emit-sequence-start ]
445 [ nip emit-sequence-body ]
446 [ 2drop emit-sequence-end ] 4tri ;
448 M: linked-assoc emit-value ( emitter event anchor assoc -- )
449 [ drop YAML_OMAP_TAG f emit-sequence-start ]
450 [ nip emit-linked-assoc-body ]
451 [ 2drop emit-sequence-end ] 4tri ;
453 :: emit-assoc-start ( emitter event anchor tag implicit -- )
454 event anchor tag implicit YAML_ANY_MAPPING_STYLE
455 yaml_mapping_start_event_initialize yaml-initialize-assert-ok
456 emitter event yaml_emitter_emit_asserted ;
458 : emit-assoc-end ( emitter event -- )
459 dup yaml_mapping_end_event_initialize yaml-initialize-assert-ok
460 yaml_emitter_emit_asserted ;
462 M: assoc emit-value ( emitter event anchor assoc -- )
463 [ drop YAML_MAP_TAG implicit-tags get emit-assoc-start ]
464 [ nip emit-assoc-body ]
465 [ 2drop emit-assoc-end ] 4tri ;
467 M: sets:set emit-value ( emitter event anchor set -- )
468 [ drop YAML_SET_TAG f emit-assoc-start ]
469 [ nip emit-set-body ]
470 [ 2drop emit-assoc-end ] 4tri ;
472 : unless-libyaml-default ( variable quot -- )
473 [ get dup +libyaml-default+ = not ] dip
474 [ 2drop ] if ; inline
476 : init-emitter-options ( emitter -- )
478 [ emitter-canonical [ yaml_emitter_set_canonical ] unless-libyaml-default ]
479 [ emitter-indent [ yaml_emitter_set_indent ] unless-libyaml-default ]
480 [ emitter-width [ yaml_emitter_set_width ] unless-libyaml-default ]
481 [ emitter-unicode [ yaml_emitter_set_unicode ] unless-libyaml-default ]
482 [ emitter-line-break [ yaml_emitter_set_break ] unless-libyaml-default ]
485 ! registers destructors (use with with-destructors)
486 :: init-emitter ( -- emitter event )
487 yaml_emitter_t (malloc-struct) &free :> emitter
488 emitter yaml_emitter_initialize yaml-initialize-assert-ok
489 emitter &yaml_emitter_delete drop
490 emitter init-emitter-options
492 BV{ } clone :> output
493 output yaml-write-buffer set-global
494 emitter yaml-write-handler f yaml_emitter_set_output
496 yaml_event_t (malloc-struct) &free :> event
498 event YAML_UTF8_ENCODING
499 yaml_stream_start_event_initialize yaml-initialize-assert-ok
501 emitter event yaml_emitter_emit_asserted
504 :: emit-doc ( emitter event obj -- )
505 event f f f implicit-start get yaml_document_start_event_initialize yaml-initialize-assert-ok
506 emitter event yaml_emitter_emit_asserted
508 emitter event obj emit-object
510 event implicit-end get yaml_document_end_event_initialize yaml-initialize-assert-ok
511 emitter event yaml_emitter_emit_asserted ;
513 :: flush-emitter ( emitter event -- str )
514 event yaml_stream_end_event_initialize yaml-initialize-assert-ok
515 emitter event yaml_emitter_emit_asserted
517 emitter [ yaml_emitter_flush ] [ yaml-emitter-assert-ok ] bi
518 yaml-write-buffer get utf8 decode ;
522 : >yaml ( obj -- str )
525 [ replace-identities emit-doc ] [ drop flush-emitter ] 3bi
528 : >yaml-docs ( seq -- str )
531 [ [ replace-identities emit-doc ] 2with each ] [ drop flush-emitter ] 3bi