YAML: add yaml-docs> and >yaml-docs

extra/yaml/yaml-tests.factor

@@ -5,6 +5,7 @@ IN: yaml.tests
 
 ! TODO real conformance tests here
 
+! Basic test
 CONSTANT: test-string """--- # Favorite movies
  - Casablanca
  - North by Northwest
@@ -36,6 +37,7 @@ ${ test-obj } [ $ test-string yaml> ] unit-test
 ${ test-represented-string } [ $ test-obj >yaml ] unit-test
 ${ test-represented-string } [ $ test-represented-string yaml> >yaml ] unit-test
 
+! Non-scalar key
 CONSTANT: complex-key H{ { { "4" } "3" } }
 CONSTANT: complex-key-represented """--- !!map
 ? !!seq
@@ -45,3 +47,20 @@ CONSTANT: complex-key-represented """--- !!map
 """
 
 ${ complex-key } [ $ complex-key-represented yaml> ] unit-test
+
+! Multiple docs
+CONSTANT: test-docs """--- !!str a
+...
+--- !!seq
+- !!str b
+- !!str c
+...
+--- !!map
+!!str d: !!str e
+...
+"""
+CONSTANT: test-objs { "a" { "b" "c" } H{ { "d" "e" } } }
+
+${ test-objs } [ $ test-docs yaml-docs> ] unit-test
+${ test-docs } [ $ test-objs >yaml-docs ] unit-test
+${ test-docs } [ $ test-docs yaml-docs> >yaml-docs ] unit-test

extra/yaml/yaml.factor

@@ -59,28 +59,42 @@ DEFER: parse-mapping
   [ "wrong event" throw ] unless
 ] with-destructors ;
 
+:: ?parse-yaml-doc ( parser event -- obj/f ? )
+  [ parser event next-event type>> {
+    { YAML_DOCUMENT_START_EVENT  [ t ] }
+    { YAML_STREAM_END_EVENT [ f ] }
+    [ "wrong event" throw ]
+  } case ] with-destructors
+  [ parser event next-value t
+    parser event YAML_DOCUMENT_END_EVENT expect-event
+  ] [ f f ] if ;
 
-:: yaml> ( str -- obj )
-[
-yaml_parser_t (malloc-struct) &free :> parser
-parser yaml_parser_initialize yaml-assert-ok
-parser &yaml_parser_delete drop
+! registers destructors (use with with-destructors)
+:: init-parser ( str -- parser event )
+  yaml_parser_t (malloc-struct) &free :> parser
+  parser yaml_parser_initialize yaml-assert-ok
+  parser &yaml_parser_delete drop
 
-str utf8 encode [ malloc-byte-array &free ] [ length ] bi :> ( input length )
-parser input length yaml_parser_set_input_string
+  str utf8 encode [ malloc-byte-array &free ] [ length ] bi :> ( input length )
+  parser input length yaml_parser_set_input_string
 
-yaml_event_t (malloc-struct) &free :> event
+  yaml_event_t (malloc-struct) &free :> event
+  parser event
+;
 
-parser event YAML_STREAM_START_EVENT expect-event
-parser event YAML_DOCUMENT_START_EVENT expect-event
-
-parser event next-value
-
-parser event YAML_DOCUMENT_END_EVENT expect-event
-parser event YAML_STREAM_END_EVENT expect-event
 
+: yaml> ( str -- obj ) [
+  init-parser
+  [ YAML_STREAM_START_EVENT expect-event ]
+  [ ?parse-yaml-doc [ "No Document" throw ] unless ] 2bi
 ] with-destructors
+;
 
+: yaml-docs> ( str -- seq ) [
+  init-parser
+  [ YAML_STREAM_START_EVENT expect-event ]
+  [ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi
+] with-destructors
 ;
 
 ! TODO We can also pass some data when registering the write handler,
@@ -134,8 +148,8 @@ M: sequence emit-value ( emitter event seq -- )
 M: assoc emit-value ( emitter event seq -- )
   [ drop emit-assoc-start ] [ emit-assoc ] [ drop emit-assoc-end ] 3tri ;
 
-:: >yaml ( obj -- str )
-[
+! registers destructors (use with with-destructors)
+:: init-emitter ( -- emitter event )
 yaml_emitter_t (malloc-struct) &free :> emitter
 emitter yaml_emitter_initialize yaml-assert-ok
 emitter &yaml_emitter_delete drop
@@ -148,6 +162,10 @@ yaml_event_t (malloc-struct) &free :> event
 
 event YAML_UTF8_ENCODING yaml_stream_start_event_initialize yaml-assert-ok
 emitter event yaml_emitter_emit yaml-assert-ok
+emitter event
+;
+
+:: emit-doc ( emitter event obj -- )
 event f f f 0 yaml_document_start_event_initialize yaml-assert-ok
 emitter event yaml_emitter_emit yaml-assert-ok
 
@@ -155,12 +173,25 @@ emitter event obj emit-value
 
 event 0 yaml_document_end_event_initialize yaml-assert-ok
 emitter event yaml_emitter_emit yaml-assert-ok
+;
+
+! registers destructors (use with with-destructors)
+:: flush-emitter ( emitter event -- str )
 event yaml_stream_end_event_initialize yaml-assert-ok
 emitter event yaml_emitter_emit yaml-assert-ok
 
 emitter yaml_emitter_flush yaml-assert-ok
 yaml-write-buffer get utf8 decode
-
-] with-destructors
-
+;
+
+: >yaml ( obj -- str ) [
+[ init-emitter ] dip
+[ emit-doc ] [ drop flush-emitter ] 3bi
+] with-destructors
+;
+
+: >yaml-docs ( seq -- str ) [
+[ init-emitter ] dip
+[ [ emit-doc ] with with each ] [ drop flush-emitter ] 3bi
+] with-destructors
 ;