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 locals 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 [ throw-libyaml-initialize-error ] unless ;
27 : (libyaml-parser-error) ( parser -- )
36 } cleave [ clone ] 7 napply throw-libyaml-parser-error ;
38 : (libyaml-emitter-error) ( emitter -- )
39 [ error>> ] [ problem>> ] bi [ clone ] bi@ throw-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 ] [ throw-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 throw-yaml-unexpected-event ] if
188 ! Same as 'with', but for combinators that
189 ! put 2 arguments on the stack
190 : with2 ( param obj quot -- obj curry )
191 swapd '[ [ _ ] 2dip @ ] ; inline
193 GENERIC: (deref-aliases) ( anchors obj -- obj' )
195 M: object (deref-aliases) nip ;
197 M: byte-array (deref-aliases) nip ;
199 M: string (deref-aliases) nip ;
201 M: yaml-alias (deref-aliases) anchor>> of ;
203 M: sequence (deref-aliases)
204 [ (deref-aliases) ] with map! ;
206 M: unordered-set (deref-aliases)
207 [ members (deref-aliases) ] [ clear-set ] [ swap union! ] tri ;
209 : assoc-map! ( assoc quot -- assoc' )
210 [ assoc-map ] [ drop clear-assoc ] [ drop swap assoc-union! ] 2tri ; inline
212 M: assoc (deref-aliases)
213 [ [ (deref-aliases) ] bi-curry@ bi ] with2 assoc-map! ;
215 : merge-values ( seq -- assoc )
216 reverse unclip [ assoc-union ] reduce ;
217 GENERIC: merge-value ( assoc value -- assoc' )
218 M: sequence merge-value merge-values merge-value ;
219 M: assoc merge-value over assoc-diff assoc-union! ;
220 : pop-at* ( key assoc -- value/f ? )
221 [ at* ] 2keep pick [ delete-at ] [ 2drop ] if ;
223 : ?apply-default-key ( assoc -- obj' )
224 T{ yaml-value } over pop-at* [ nip ] [ drop ] if ;
227 : ?apply-merge-key ( assoc -- assoc' )
228 T{ yaml-merge } over pop-at*
229 [ merge-value ] [ drop ] if ;
230 : scalar-value ( obj -- obj' )
231 dup hashtable? [ ?apply-default-key ] when ;
235 GENERIC: apply-merge-keys ( already-applied-set obj -- obj' )
236 : ?apply-merge-keys ( set obj -- obj' )
237 2dup swap in? [ nip ] [ 2dup swap adjoin apply-merge-keys ] if ;
238 M: sequence apply-merge-keys
239 [ ?apply-merge-keys ] with map! ;
240 M: object apply-merge-keys nip ;
241 M: byte-array apply-merge-keys nip ;
242 M: string apply-merge-keys nip ;
243 M: assoc apply-merge-keys
244 [ [ ?apply-merge-keys ] bi-curry@ bi ] with2 assoc-map!
245 merge get [ ?apply-merge-key ] when
246 value get [ ?apply-default-key ] when ;
248 :: parse-yaml-doc ( parser event -- obj )
250 parser event next-value
251 anchors get swap (deref-aliases)
252 merge get value get or [ IHS{ } clone swap ?apply-merge-keys ] when
255 :: ?parse-yaml-doc ( parser event -- obj/f ? )
257 parser event next-event type>> {
258 { YAML_DOCUMENT_START_EVENT [ t ] }
259 { YAML_STREAM_END_EVENT [ f ] }
260 [ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } throw-yaml-unexpected-event ]
263 parser event parse-yaml-doc t
264 parser event YAML_DOCUMENT_END_EVENT expect-event
267 ! registers destructors (use with with-destructors)
268 :: init-parser ( str -- parser event )
269 yaml_parser_t (malloc-struct) &free :> parser
270 parser yaml_parser_initialize yaml-initialize-assert-ok
271 parser &yaml_parser_delete drop
274 [ malloc-byte-array &free ] [ length ] bi :> ( input length )
275 parser input length yaml_parser_set_input_string
277 yaml_event_t (malloc-struct) &free :> event
282 : yaml> ( str -- obj )
285 [ YAML_STREAM_START_EVENT expect-event ]
286 [ ?parse-yaml-doc [ throw-yaml-no-document ] unless ] 2bi
289 : yaml-docs> ( str -- arr )
292 [ YAML_STREAM_START_EVENT expect-event ]
293 [ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi
298 TUPLE: yaml-anchors objects new-objects next-anchor ;
300 : <yaml-anchors> ( -- yaml-anchors )
301 IH{ } clone IH{ } clone 0 yaml-anchors boa ;
303 GENERIC: (replace-aliases) ( yaml-anchors obj -- obj' )
305 : incr-anchor ( yaml-anchors -- current-anchor )
307 [ [ number>string ] [ 1 + ] bi ]
308 [ next-anchor<< ] bi*
311 :: (?replace-aliases) ( yaml-anchors obj -- obj' )
312 yaml-anchors objects>> :> objects
314 [ yaml-anchors incr-anchor dup obj objects set-at ] unless*
317 drop f obj objects set-at
318 yaml-anchors obj (replace-aliases) :> obj'
319 obj obj' yaml-anchors new-objects>> set-at
323 : ?replace-aliases ( yaml-anchors obj -- obj' )
324 dup fixnum? [ nip ] [ (?replace-aliases) ] if ;
326 M: object (replace-aliases) nip ;
328 M: byte-array (replace-aliases) nip ;
330 M: string (replace-aliases) nip ;
332 M: sequence (replace-aliases)
333 [ ?replace-aliases ] with map ;
335 M: unordered-set (replace-aliases)
336 [ members (replace-aliases) ] keep set-like ;
338 M: assoc (replace-aliases)
339 swap '[ [ _ swap ?replace-aliases ] bi@ ] assoc-map ;
341 TUPLE: yaml-anchor anchor obj ;
342 C: <yaml-anchor> yaml-anchor
344 GENERIC: (replace-anchors) ( yaml-anchors obj -- obj' )
346 : (get-anchor) ( yaml-anchors obj -- anchor/f )
349 : get-anchor ( yaml-anchors obj -- anchor/f )
350 { [ (get-anchor) ] [ over new-objects>> at (get-anchor) ] } 2|| ;
352 : ?replace-anchors ( yaml-anchors obj -- obj' )
353 [ (replace-anchors) ] [ get-anchor ] 2bi [ swap <yaml-anchor> ] when* ;
355 M: object (replace-anchors) nip ;
357 M: byte-array (replace-anchors) nip ;
359 M: string (replace-anchors) nip ;
361 M: sequence (replace-anchors)
362 [ ?replace-anchors ] with map ;
364 M: unordered-set (replace-anchors)
365 [ members ?replace-anchors ] keep set-like ;
367 M: assoc (replace-anchors)
368 swap '[ [ _ swap ?replace-anchors ] bi@ ] assoc-map ;
370 : replace-identities ( obj -- obj' )
371 [ <yaml-anchors> ] dip dupd ?replace-aliases ?replace-anchors ;
373 ! TODO We can also pass some data when registering the write handler,
374 ! use this to have several buffers if it can be interrupted.
375 ! For now, only do operations on strings that are in memory
376 ! so we don't need to be reentrant.
377 SYMBOL: yaml-write-buffer
378 : yaml-write-handler ( -- alien )
380 memory>byte-array yaml-write-buffer get-global
382 ] yaml_write_handler_t ;
384 GENERIC: emit-value ( emitter event anchor obj -- )
386 : emit-object ( emitter event obj -- ) [ f ] dip emit-value ;
388 : scalar-implicit-tag? ( tag str mapping-key? -- plain_implicit quoted_implicit )
390 resolve-plain-scalar = t
393 :: (emit-scalar) ( emitter event anchor obj mapping-key? -- )
395 obj [ yaml-tag ] [ represent-scalar ] bi
396 -1 2over mapping-key? scalar-implicit-tag? YAML_ANY_SCALAR_STYLE
397 yaml_scalar_event_initialize yaml-initialize-assert-ok
398 emitter event yaml_emitter_emit_asserted ;
400 : emit-mapping-key-scalar ( emitter event anchor obj -- ) t (emit-scalar) ;
401 : emit-scalar ( emitter event anchor obj -- ) f (emit-scalar) ;
403 ! strings and special keys are the only things that need special treatment
404 ! because they can have the same representation
405 : emit-mapping-key ( emitter event obj -- )
406 dup { [ string? ] [ yaml-merge? ] [ yaml-value? ] } 1||
407 [ [ f ] dip emit-mapping-key-scalar ] [ emit-object ] if ;
409 M: object emit-value ( emitter event anchor obj -- ) emit-scalar ;
411 M: yaml-anchor emit-value ( emitter event unused obj -- )
412 nip [ anchor>> ] [ obj>> ] bi emit-value ;
414 M:: yaml-alias emit-value ( emitter event unused obj -- )
415 event obj anchor>> yaml_alias_event_initialize yaml-initialize-assert-ok
416 emitter event yaml_emitter_emit_asserted ;
418 :: emit-sequence-start ( emitter event anchor tag implicit -- )
419 event anchor tag implicit YAML_ANY_SEQUENCE_STYLE
420 yaml_sequence_start_event_initialize yaml-initialize-assert-ok
421 emitter event yaml_emitter_emit_asserted ;
423 : emit-sequence-end ( emitter event -- )
424 dup yaml_sequence_end_event_initialize yaml-initialize-assert-ok
425 yaml_emitter_emit_asserted ;
427 : emit-sequence-body ( emitter event seq -- )
428 [ emit-object ] 2with each ;
430 : emit-assoc-body ( emitter event assoc -- )
433 [ emit-object ] bi-curry* 2bi
434 ] with2 with2 assoc-each ;
436 : emit-linked-assoc-body ( emitter event linked-assoc -- )
437 >alist [ first2 swap associate ] map emit-sequence-body ;
439 : emit-set-body ( emitter event set -- )
440 [ members ] [ cardinality f <array> ] bi zip concat emit-sequence-body ;
442 M: f emit-value ( emitter event anchor f -- ) emit-scalar ;
444 M: string emit-value ( emitter event anchor string -- ) emit-scalar ;
446 M: byte-array emit-value ( emitter event anchor byte-array -- ) emit-scalar ;
448 M: sequence emit-value ( emitter event anchor seq -- )
449 [ drop YAML_SEQ_TAG implicit-tags get emit-sequence-start ]
450 [ nip emit-sequence-body ]
451 [ 2drop emit-sequence-end ] 4tri ;
453 M: linked-assoc emit-value ( emitter event anchor assoc -- )
454 [ drop YAML_OMAP_TAG f emit-sequence-start ]
455 [ nip emit-linked-assoc-body ]
456 [ 2drop emit-sequence-end ] 4tri ;
458 :: emit-assoc-start ( emitter event anchor tag implicit -- )
459 event anchor tag implicit YAML_ANY_MAPPING_STYLE
460 yaml_mapping_start_event_initialize yaml-initialize-assert-ok
461 emitter event yaml_emitter_emit_asserted ;
463 : emit-assoc-end ( emitter event -- )
464 dup yaml_mapping_end_event_initialize yaml-initialize-assert-ok
465 yaml_emitter_emit_asserted ;
467 M: assoc emit-value ( emitter event anchor assoc -- )
468 [ drop YAML_MAP_TAG implicit-tags get emit-assoc-start ]
469 [ nip emit-assoc-body ]
470 [ 2drop emit-assoc-end ] 4tri ;
472 M: unordered-set emit-value ( emitter event anchor set -- )
473 [ drop YAML_SET_TAG f emit-assoc-start ]
474 [ nip emit-set-body ]
475 [ 2drop emit-assoc-end ] 4tri ;
477 : unless-libyaml-default ( variable quot -- )
478 [ get dup +libyaml-default+ = not ] dip
479 [ 2drop ] if ; inline
481 : init-emitter-options ( emitter -- )
483 [ emitter-canonical [ yaml_emitter_set_canonical ] unless-libyaml-default ]
484 [ emitter-indent [ yaml_emitter_set_indent ] unless-libyaml-default ]
485 [ emitter-width [ yaml_emitter_set_width ] unless-libyaml-default ]
486 [ emitter-unicode [ yaml_emitter_set_unicode ] unless-libyaml-default ]
487 [ emitter-line-break [ yaml_emitter_set_break ] unless-libyaml-default ]
490 ! registers destructors (use with with-destructors)
491 :: init-emitter ( -- emitter event )
492 yaml_emitter_t (malloc-struct) &free :> emitter
493 emitter yaml_emitter_initialize yaml-initialize-assert-ok
494 emitter &yaml_emitter_delete drop
495 emitter init-emitter-options
497 BV{ } clone :> output
498 output yaml-write-buffer set-global
499 emitter yaml-write-handler f yaml_emitter_set_output
501 yaml_event_t (malloc-struct) &free :> event
503 event YAML_UTF8_ENCODING
504 yaml_stream_start_event_initialize yaml-initialize-assert-ok
506 emitter event yaml_emitter_emit_asserted
509 :: emit-doc ( emitter event obj -- )
510 event f f f implicit-start get yaml_document_start_event_initialize yaml-initialize-assert-ok
511 emitter event yaml_emitter_emit_asserted
513 emitter event obj emit-object
515 event implicit-end get yaml_document_end_event_initialize yaml-initialize-assert-ok
516 emitter event yaml_emitter_emit_asserted ;
518 :: flush-emitter ( emitter event -- str )
519 event yaml_stream_end_event_initialize yaml-initialize-assert-ok
520 emitter event yaml_emitter_emit_asserted
522 emitter [ yaml_emitter_flush ] [ yaml-emitter-assert-ok ] bi
523 yaml-write-buffer get utf8 decode ;
527 : >yaml ( obj -- str )
530 [ replace-identities emit-doc ] [ drop flush-emitter ] 3bi
533 : >yaml-docs ( seq -- str )
536 [ [ replace-identities emit-doc ] 2with each ] [ drop flush-emitter ] 3bi