diff --git a/extra/yaml/yaml-docs.factor b/extra/yaml/yaml-docs.factor new file mode 100644 index 0000000000..3619f66614 --- /dev/null +++ b/extra/yaml/yaml-docs.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2014 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs help.markup help.syntax kernel sequences +strings ; +IN: yaml + +HELP: >yaml +{ $values + { "obj" object } + { "str" string } +} +{ $description "Serializes the object into a YAML formatted string." } ; + +HELP: >yaml-docs +{ $values + { "seq" sequence } + { "str" string } +} +{ $description "Serializes the sequence into a YAML formatted string. Each element is outputted as a YAML document" } ; + +HELP: yaml-docs> +{ $values + { "str" string } + { "arr" array } +} +{ $description "Deserializes the YAML formatted string into a Factor array. Each document becomes an element of the array" } ; + +HELP: yaml> +{ $values + { "str" string } + { "obj" object } +} +{ $description "Deserializes the YAML formatted string into a Factor object." } ; + +ARTICLE: "yaml" "YAML serialization" +"The " { $vocab-link "yaml" } " vocabulary implements YAML serialization/deserialization." +{ $subsections + >yaml + >yaml-docs + yaml> + yaml-docs> +} +; + +{ >yaml >yaml-docs } related-words +{ yaml> yaml-docs> } related-words + +ABOUT: "yaml" diff --git a/extra/yaml/yaml.factor b/extra/yaml/yaml.factor index c580f877d9..8784304761 100644 --- a/extra/yaml/yaml.factor +++ b/extra/yaml/yaml.factor @@ -6,10 +6,17 @@ io.encodings.string io.encodings.utf8 kernel libc locals make math namespaces prettyprint sequences strings yaml.ffi ; IN: yaml +scalar ( event -- obj ) data>> scalar>> [ value>> ] [ length>> ] bi memory>byte-array utf8 decode ; + +: event>scalar ( event -- obj ) + data>> scalar>> [ value>> ] [ length>> ] bi + memory>byte-array utf8 decode ; + : ?scalar-value ( event -- scalar/f f/type ) - dup type>> YAML_SCALAR_EVENT = [ event>scalar f ] [ type>> clone f swap ] if ; + dup type>> YAML_SCALAR_EVENT = + [ event>scalar f ] [ type>> clone f swap ] if ; ! Must not reuse the event struct before with-destructors scope ends : next-event ( parser event -- event ) @@ -18,84 +25,100 @@ IN: yaml DEFER: parse-sequence DEFER: parse-mapping : next-complex-value ( parser event type -- obj ) - { - { YAML_SEQUENCE_START_EVENT [ parse-sequence ] } - { YAML_MAPPING_START_EVENT [ parse-mapping ] } - [ throw ] - } case ; -:: next-value ( parser event -- obj ) - parser event [ next-event ?scalar-value ] with-destructors - [ [ drop parser event ] dip next-complex-value ] when* ; + { + { YAML_SEQUENCE_START_EVENT [ parse-sequence ] } + { YAML_MAPPING_START_EVENT [ parse-mapping ] } + [ throw ] + } case ; -:: parse-mapping ( parser event -- map ) [ - f :> done! - [ done ] [ [ - parser event next-event type>> - YAML_MAPPING_END_EVENT = [ - t done! f f - ] [ - event ?scalar-value - ] if - ] with-destructors 2dup or [ - [ nip [ parser event ] dip next-complex-value ] when* - parser event next-value swap ,, - ] [ 2drop ] if ] until -] H{ } make ; -:: parse-sequence ( parser event -- seq ) [ - f :> done! - [ done ] [ [ - parser event next-event type>> - YAML_SEQUENCE_END_EVENT = [ - t done! f - ] [ - event ?scalar-value dup [ nip ] [ [ , ] dip ] if - ] if - ] with-destructors [ [ parser event ] dip next-complex-value , ] when* ] until -] { } make ; +:: next-value ( parser event -- obj ) + parser event [ next-event ?scalar-value ] with-destructors + [ [ drop parser event ] dip next-complex-value ] when* ; + +:: parse-mapping ( parser event -- map ) + [ + f :> done! + [ done ] [ + [ + parser event next-event type>> + YAML_MAPPING_END_EVENT = [ + t done! f f + ] [ + event ?scalar-value + ] if + ] with-destructors + 2dup or [ + [ nip [ parser event ] dip next-complex-value ] when* + parser event next-value swap ,, + ] [ 2drop ] if + ] until + ] H{ } make ; + +:: parse-sequence ( parser event -- seq ) + [ + f :> done! + [ done ] [ + [ + parser event next-event type>> + YAML_SEQUENCE_END_EVENT = [ + t done! f + ] [ + event ?scalar-value dup [ nip ] [ [ , ] dip ] if + ] if + ] with-destructors + [ [ parser event ] dip next-complex-value , ] when* + ] until + ] { } make ; : expect-event ( parser event type -- ) -[ - [ next-event type>> ] dip = - [ "wrong event" throw ] unless -] with-destructors ; + [ + [ next-event type>> ] dip = + [ "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 ; + [ + 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 ; ! 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 + 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 - parser event -; + yaml_event_t (malloc-struct) &free :> event + parser event ; +PRIVATE> -: yaml> ( str -- obj ) [ - init-parser - [ YAML_STREAM_START_EVENT expect-event ] - [ ?parse-yaml-doc [ "No Document" throw ] unless ] 2bi -] with-destructors -; +: 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 -; +: yaml-docs> ( str -- arr ) + [ + init-parser + [ YAML_STREAM_START_EVENT expect-event ] + [ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi + ] with-destructors ; + +byte-array yaml-write-buffer get-global - push-all drop 1 - ] yaml_write_handler_t ; + [ + memory>byte-array yaml-write-buffer get-global + push-all drop 1 + ] yaml_write_handler_t ; GENERIC: emit-value ( emitter event obj -- ) + M:: string emit-value ( emitter event string -- ) -[ - string utf8 encode [ malloc-byte-array &free ] [ length ] bi :> ( value length ) - "tag:yaml.org,2002:str" utf8 malloc-string &free :> tag - event f tag value length 0 0 0 yaml_scalar_event_initialize yaml-assert-ok - emitter event yaml_emitter_emit yaml-assert-ok -] with-destructors ; + [ + string utf8 encode + [ malloc-byte-array &free ] [ length ] bi :> ( value length ) + + "tag:yaml.org,2002:str" utf8 malloc-string &free :> tag + + event f tag value length 0 0 0 + yaml_scalar_event_initialize yaml-assert-ok + + emitter event yaml_emitter_emit yaml-assert-ok + ] with-destructors ; + :: emit-sequence-start ( emitter event -- ) -[ - "tag:yaml.org,2002:seq" utf8 malloc-string &free :> tag - event f tag 0 0 yaml_sequence_start_event_initialize yaml-assert-ok - emitter event yaml_emitter_emit yaml-assert-ok -] with-destructors ; + [ + "tag:yaml.org,2002:seq" utf8 malloc-string &free :> tag + + event f tag 0 0 + yaml_sequence_start_event_initialize yaml-assert-ok + + emitter event yaml_emitter_emit yaml-assert-ok + ] with-destructors ; : emit-sequence-end ( emitter event -- ) - dup yaml_sequence_end_event_initialize yaml-assert-ok - yaml_emitter_emit yaml-assert-ok ; + dup yaml_sequence_end_event_initialize yaml-assert-ok + yaml_emitter_emit yaml-assert-ok ; : emit-sequence ( emitter event seq -- ) - [ emit-value ] with with each ; + [ emit-value ] with with each ; M: sequence emit-value ( emitter event seq -- ) - [ drop emit-sequence-start ] [ emit-sequence ] [ drop emit-sequence-end ] 3tri ; + [ drop emit-sequence-start ] + [ emit-sequence ] + [ drop emit-sequence-end ] 3tri ; :: emit-assoc-start ( emitter event -- ) -[ - "tag:yaml.org,2002:map" utf8 malloc-string &free :> tag - event f tag 0 0 yaml_mapping_start_event_initialize yaml-assert-ok - emitter event yaml_emitter_emit yaml-assert-ok -] with-destructors ; + [ + "tag:yaml.org,2002:map" utf8 malloc-string &free :> tag + + event f tag 0 0 + yaml_mapping_start_event_initialize yaml-assert-ok + + emitter event yaml_emitter_emit yaml-assert-ok + ] with-destructors ; : emit-assoc-end ( emitter event -- ) - dup yaml_mapping_end_event_initialize yaml-assert-ok - yaml_emitter_emit yaml-assert-ok ; + dup yaml_mapping_end_event_initialize yaml-assert-ok + yaml_emitter_emit yaml-assert-ok ; : emit-assoc ( emitter event assoc -- ) - [ [ emit-value ] with with bi@ ] with with assoc-each ; + [ [ emit-value ] with with bi@ ] with with assoc-each ; M: assoc emit-value ( emitter event seq -- ) - [ drop emit-assoc-start ] [ emit-assoc ] [ drop emit-assoc-end ] 3tri ; + [ drop emit-assoc-start ] + [ emit-assoc ] + [ drop emit-assoc-end ] 3tri ; ! 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 + yaml_emitter_t (malloc-struct) &free :> emitter + emitter yaml_emitter_initialize yaml-assert-ok + emitter &yaml_emitter_delete drop -BV{ } clone :> output -output yaml-write-buffer set-global -emitter yaml-write-handler f yaml_emitter_set_output + BV{ } clone :> output + output yaml-write-buffer set-global + emitter yaml-write-handler f yaml_emitter_set_output -yaml_event_t (malloc-struct) &free :> event + 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 -; + 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 + event f f f 0 yaml_document_start_event_initialize yaml-assert-ok + emitter event yaml_emitter_emit yaml-assert-ok -emitter event obj emit-value + emitter event obj emit-value -event 0 yaml_document_end_event_initialize yaml-assert-ok -emitter event yaml_emitter_emit yaml-assert-ok -; + 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 + 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 -; + emitter yaml_emitter_flush yaml-assert-ok + yaml-write-buffer get utf8 decode ; -: >yaml ( obj -- str ) [ -[ init-emitter ] dip -[ emit-doc ] [ drop flush-emitter ] 3bi -] with-destructors -; +PRIVATE> -: >yaml-docs ( seq -- str ) [ -[ init-emitter ] dip -[ [ emit-doc ] with with each ] [ drop flush-emitter ] 3bi -] 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 ;