diff --git a/extra/yaml/conversion/conversion.factor b/extra/yaml/conversion/conversion.factor index 8d52a71dd7..308a42f73d 100644 --- a/extra/yaml/conversion/conversion.factor +++ b/extra/yaml/conversion/conversion.factor @@ -9,37 +9,42 @@ IN: yaml.conversion ! tag resolution ! http://www.yaml.org/spec/1.2/spec.html ! 10.3. Core Schema -: resolve-null? ( str -- ? ) R/ null|Null|NULL|~/ matches? ; -: resolve-empty? ( str -- ? ) R/ / matches? ; -: resolve-bool? ( str -- ? ) R/ true|True|TRUE|false|False|FALSE/ matches? ; -: resolve-int10? ( str -- ? ) R/ [-+]?[0-9]+/ matches? ; -: resolve-int8? ( str -- ? ) R/ 0o[0-7]+/ matches? ; -: resolve-int16? ( str -- ? ) R/ 0x[0-9a-fA-F]+/ matches? ; -: resolve-number? ( str -- ? ) R/ [-+]?(\.[0-9]+|[0-9]+(\.[0-9]*)?)([eE][-+]?[0-9]+)?/ matches? ; -: resolve-infinity? ( str -- ? ) R/ [-+]?(\.inf|\.Inf|\.INF)/ matches? ; -: resolve-nan? ( str -- ? ) R/ \.nan|\.NaN|\.NAN/ matches? ; + +CONSTANT: re-null R/ null|Null|NULL|~/ +CONSTANT: re-empty R/ / +CONSTANT: re-bool R/ true|True|TRUE|false|False|FALSE/ +CONSTANT: re-int10 R/ [-+]?[0-9]+/ +CONSTANT: re-int8 R/ 0o[0-7]+/ +CONSTANT: re-int16 R/ 0x[0-9a-fA-F]+/ +CONSTANT: re-number R/ [-+]?(\.[0-9]+|[0-9]+(\.[0-9]*)?)([eE][-+]?[0-9]+)?/ +CONSTANT: re-infinity R/ [-+]?\.(inf|Inf|INF)/ +CONSTANT: re-nan R/ \.(nan|NaN|NAN)/ : resolve-plain-scalar ( str -- tag ) { - { [ resolve-null? ] [ YAML_NULL_TAG ] } - { [ resolve-empty? ] [ YAML_NULL_TAG ] } - { [ resolve-bool? ] [ YAML_BOOL_TAG ] } - { [ resolve-int10? ] [ YAML_INT_TAG ] } - { [ resolve-int8? ] [ YAML_INT_TAG ] } - { [ resolve-int16? ] [ YAML_INT_TAG ] } - { [ resolve-number? ] [ YAML_FLOAT_TAG ] } - { [ resolve-infinity? ] [ YAML_FLOAT_TAG ] } - { [ resolve-nan? ] [ YAML_FLOAT_TAG ] } + { [ re-null matches? ] [ YAML_NULL_TAG ] } + { [ re-empty matches? ] [ YAML_NULL_TAG ] } + { [ re-bool matches? ] [ YAML_BOOL_TAG ] } + { [ re-int10 matches? ] [ YAML_INT_TAG ] } + { [ re-int8 matches? ] [ YAML_INT_TAG ] } + { [ re-int16 matches? ] [ YAML_INT_TAG ] } + { [ re-number matches? ] [ YAML_FLOAT_TAG ] } + { [ re-infinity matches? ] [ YAML_FLOAT_TAG ] } + { [ re-nan matches? ] [ YAML_FLOAT_TAG ] } [ drop YAML_STR_TAG ] } cond-case ; CONSTANT: NON-SPECIFIC-TAG "!" + : resolve-explicit-tag ( tag default-tag -- tag ) [ drop NON-SPECIFIC-TAG = not ] 2keep ? ; + : resolve-explicit-scalar-tag ( tag -- tag ) YAML_DEFAULT_SCALAR_TAG resolve-explicit-tag ; + : resolve-explicit-sequence-tag ( tag -- tag ) YAML_DEFAULT_SEQUENCE_TAG resolve-explicit-tag ; + : resolve-explicit-mapping-tag ( tag -- tag ) YAML_DEFAULT_MAPPING_TAG resolve-explicit-tag ; @@ -52,34 +57,42 @@ CONSTANT: NON-SPECIFIC-TAG "!" ! !!!!!!!!!!!!!! ! yaml -> factor -: construct-bool ( str -- ? ) R/ true|True|TRUE/ matches? ; -: construct-int ( str -- n ) string>number ; + +CONSTANT: YAML_BINARY_TAG "tag:yaml.org,2002:binary" +CONSTANT: YAML_OMAP_TAG "tag:yaml.org,2002:omap" +CONSTANT: YAML_PAIRS_TAG "tag:yaml.org,2002:pairs" +CONSTANT: YAML_SET_TAG "tag:yaml.org,2002:set" + +: construct-bool ( str -- ? ) R/ true|True|TRUE/ matches? ; + +: construct-int ( str -- n ) string>number ; + : construct-infinity ( str -- -inf/+inf ) - first CHAR: - = - [ -1/0. ] [ 1/0. ] if ; + first CHAR: - = -1/0. 1/0. ? ; + : construct-float ( str -- x ) { - { [ dup resolve-infinity? ] [ construct-infinity ] } - { [ dup resolve-nan? ] [ drop 1/0. ] } + { [ dup re-infinity matches? ] [ construct-infinity ] } + { [ dup re-nan matches? ] [ drop 1/0. ] } [ string>number ] } cond ; -CONSTANT: YAML_BINARY_TAG "tag:yaml.org,2002:binary" - : construct-scalar ( scalar-event -- scalar ) [ value>> ] [ resolve-scalar ] bi { - { YAML_NULL_TAG [ drop f ] } - { YAML_BOOL_TAG [ construct-bool ] } - { YAML_INT_TAG [ construct-int ] } + { YAML_NULL_TAG [ drop f ] } + { YAML_BOOL_TAG [ construct-bool ] } + { YAML_INT_TAG [ construct-int ] } { YAML_FLOAT_TAG [ construct-float ] } { YAML_BINARY_TAG [ base64> ] } - { YAML_STR_TAG [ ] } + { YAML_STR_TAG [ ] } } case ; -CONSTANT: YAML_OMAP_TAG "tag:yaml.org,2002:omap" -CONSTANT: YAML_PAIRS_TAG "tag:yaml.org,2002:pairs" -: construct-pairs ( obj -- obj' ) [ >alist first ] map ; -: construct-omap ( obj -- obj' ) [ assoc-union! ] reduce ; +: construct-pairs ( obj -- obj' ) + [ >alist first ] map ; + +: construct-omap ( obj -- obj' ) + [ assoc-union! ] reduce ; + : construct-sequence ( obj prev-event -- obj' ) tag>> { { YAML_OMAP_TAG [ construct-omap ] } @@ -87,8 +100,9 @@ CONSTANT: YAML_PAIRS_TAG "tag:yaml.org,2002:pairs" [ drop ] } case ; -CONSTANT: YAML_SET_TAG "tag:yaml.org,2002:set" -: construct-set ( obj -- obj' ) keys >hash-set ; +: construct-set ( obj -- obj' ) + keys >hash-set ; + : construct-mapping ( obj prev-event -- obj' ) tag>> { { YAML_SET_TAG [ construct-set ] } @@ -112,5 +126,5 @@ M: integer yaml-tag ( obj -- tag ) drop YAML_INT_TAG ; M: float represent-scalar ( obj -- str ) number>string ; M: float yaml-tag ( obj -- tag ) drop YAML_FLOAT_TAG ; -M: byte-array represent-scalar ( obj -- str ) >base64 >string ; +M: byte-array represent-scalar ( obj -- str ) >base64 "" like ; M: byte-array yaml-tag ( obj -- tag ) drop YAML_BINARY_TAG ; diff --git a/extra/yaml/dbg/dbg.factor b/extra/yaml/dbg/dbg.factor index 210aa75150..d2ad718d10 100644 --- a/extra/yaml/dbg/dbg.factor +++ b/extra/yaml/dbg/dbg.factor @@ -8,100 +8,103 @@ yaml.ffi yaml.private ; IN: yaml.dbg : event. ( event -- ) - dup [ data>> ] [ type>> ] bi* { - { YAML_STREAM_START_EVENT [ stream_start>> ] } - { YAML_DOCUMENT_START_EVENT [ document_start>> ] } - { YAML_DOCUMENT_END_EVENT [ document_end>> ] } - { YAML_ALIAS_EVENT [ alias>> ] } - { YAML_SCALAR_EVENT [ scalar>> ] } - { YAML_SEQUENCE_START_EVENT [ sequence_start>> ] } - { YAML_MAPPING_START_EVENT [ mapping_start>> ] } - [ nip ] - } case . ; + dup [ data>> ] [ type>> ] bi* { + { YAML_STREAM_START_EVENT [ stream_start>> ] } + { YAML_DOCUMENT_START_EVENT [ document_start>> ] } + { YAML_DOCUMENT_END_EVENT [ document_end>> ] } + { YAML_ALIAS_EVENT [ alias>> ] } + { YAML_SCALAR_EVENT [ scalar>> ] } + { YAML_SEQUENCE_START_EVENT [ sequence_start>> ] } + { YAML_MAPPING_START_EVENT [ mapping_start>> ] } + [ nip ] + } case . ; + :: yaml-events ( string -- ) -[ -yaml_parser_t (malloc-struct) &free &yaml_parser_delete :> parser -parser yaml_parser_initialize . + [ + yaml_parser_t (malloc-struct) &free &yaml_parser_delete :> parser + parser yaml_parser_initialize . -string utf8 encode [ malloc-byte-array &free ] [ length ] bi :> ( input length ) -parser input length yaml_parser_set_input_string + string 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 -f :> done! -[ - [ done ] [ - parser event yaml_parser_parse [ [ - event &yaml_event_delete event. - event type>> YAML_STREAM_END_EVENT = done! - ] with-destructors ] [ - parser (libyaml-parser-error) - ] if - ] until -] [ . ] recover + f :> done! + [ + [ done ] [ + parser event yaml_parser_parse [ [ + event &yaml_event_delete event. + event type>> YAML_STREAM_END_EVENT = done! + ] with-destructors ] [ + parser (libyaml-parser-error) + ] if + ] until + ] [ . ] recover + ] with-destructors ; -] with-destructors +: factor-struct-sizes ( -- arr ) + { + yaml_version_directive_t + yaml_tag_directive_t + yaml_mark_t + stream_start_token_data + alias_token_data + anchor_token_data + tag_token_data + scalar_token_data + version_directive_token_data + yaml_token_t + stream_start_event_data + tag_directives_document_start_event_data + document_start_event_data + document_end_event_data + alias_event_data + scalar_event_data + sequence_start_event_data + mapping_start_event_data + yaml_event_t + yaml_node_pair_t + scalar_node_data + sequence_node_data_items + sequence_node_data + mapping_node_data_pairs + mapping_node_data + yaml_node_t + yaml_document_nodes + yaml_document_tag_directives + yaml_document_t + yaml_simple_key_t + yaml_alias_data_t + string_yaml_parser_input + yaml_parser_buffer + yaml_parser_raw_buffer + yaml_parser_tokens + yaml_parser_indents + yaml_parser_simple_keys + yaml_parser_states + yaml_parser_marks + yaml_parser_tag_directives + yaml_parser_aliases + yaml_parser_t + yaml_emitter_output_string + yaml_emitter_buffer + yaml_emitter_raw_buffer + yaml_emitter_states + yaml_emitter_events + yaml_emitter_indents + yaml_emitter_tag_directives + yaml_emitter_anchor_data + yaml_emitter_tag_data + yaml_emitter_scalar_data + yaml_emitter_anchors + yaml_emitter_t + } [ heap-size ] map ; -; - -: factor-struct-sizes ( -- arr ) { -yaml_version_directive_t -yaml_tag_directive_t -yaml_mark_t -stream_start_token_data -alias_token_data -anchor_token_data -tag_token_data -scalar_token_data -version_directive_token_data -yaml_token_t -stream_start_event_data -tag_directives_document_start_event_data -document_start_event_data -document_end_event_data -alias_event_data -scalar_event_data -sequence_start_event_data -mapping_start_event_data -yaml_event_t -yaml_node_pair_t -scalar_node_data -sequence_node_data_items -sequence_node_data -mapping_node_data_pairs -mapping_node_data -yaml_node_t -yaml_document_nodes -yaml_document_tag_directives -yaml_document_t -yaml_simple_key_t -yaml_alias_data_t -string_yaml_parser_input -yaml_parser_buffer -yaml_parser_raw_buffer -yaml_parser_tokens -yaml_parser_indents -yaml_parser_simple_keys -yaml_parser_states -yaml_parser_marks -yaml_parser_tag_directives -yaml_parser_aliases -yaml_parser_t -yaml_emitter_output_string -yaml_emitter_buffer -yaml_emitter_raw_buffer -yaml_emitter_states -yaml_emitter_events -yaml_emitter_indents -yaml_emitter_tag_directives -yaml_emitter_anchor_data -yaml_emitter_tag_data -yaml_emitter_scalar_data -yaml_emitter_anchors -yaml_emitter_t } -[ heap-size ] map ; - -: c-struct-sizes ( -- sizes ) "vocab:yaml/dbg/structs" normalize-path ascii stream-lines [ string>number ] map ; +: c-struct-sizes ( -- sizes ) + "vocab:yaml/dbg/structs" normalize-path + ascii stream-lines + [ string>number ] map ; : struct-sizes-dbg ( -- ) - c-struct-sizes factor-struct-sizes zip [ first2 = not ] find . . ; + c-struct-sizes factor-struct-sizes + zip [ first2 = not ] find . . ; diff --git a/extra/yaml/yaml.factor b/extra/yaml/yaml.factor index 8365305bfe..a4afeb58ce 100644 --- a/extra/yaml/yaml.factor +++ b/extra/yaml/yaml.factor @@ -22,29 +22,43 @@ ERROR: yaml-no-document ; > ] [ problem>> ] [ problem_offset>> ] [ problem_value>> ] - [ problem_mark>> ] [ context>> ] [ context_mark>> ] + [ error>> ] + [ problem>> ] + [ problem_offset>> ] + [ problem_value>> ] + [ problem_mark>> ] + [ context>> ] + [ context_mark>> ] } cleave [ clone ] 7 napply libyaml-parser-error ; + : (libyaml-emitter-error) ( emitter -- ) [ error>> ] [ problem>> ] bi [ clone ] bi@ libyaml-emitter-error ; + : yaml-parser-assert-ok ( ? parser -- ) swap [ drop ] [ (libyaml-parser-error) ] if ; + : yaml-emitter-assert-ok ( ? emitter -- ) swap [ drop ] [ (libyaml-emitter-error) ] if ; : yaml_parser_parse_asserted ( parser event -- ) [ yaml_parser_parse ] [ drop yaml-parser-assert-ok ] 2bi ; + : yaml_emitter_emit_asserted ( emitter event -- ) [ yaml_emitter_emit ] [ drop yaml-emitter-assert-ok ] 2bi ; TUPLE: yaml-alias anchor ; C: yaml-alias + SYMBOL: anchors + : ?register-anchor ( obj event -- obj ) dupd anchor>> [ anchors get set-at ] [ drop ] if* ; + : assert-anchor-exists ( anchor -- ) anchors get 2dup at* nip [ 2drop ] [ yaml-undefined-anchor ] if ; @@ -64,20 +78,36 @@ TUPLE: factor_sequence_start_event_data anchor tag implicit style ; TUPLE: factor_mapping_start_event_data anchor tag implicit style ; TUPLE: factor_event_data sequence_start mapping_start ; TUPLE: factor_yaml_event_t type data start_mark end_mark ; + : deep-copy-seq ( data -- data' ) - { [ anchor>> clone ] [ tag>> clone ] [ implicit>> ] [ style>> ] } cleave - factor_sequence_start_event_data boa ; + { + [ anchor>> clone ] + [ tag>> clone ] + [ implicit>> ] + [ style>> ] + } cleave factor_sequence_start_event_data boa ; + : deep-copy-map ( data -- data' ) - { [ anchor>> clone ] [ tag>> clone ] [ implicit>> ] [ style>> ] } cleave - factor_mapping_start_event_data boa ; + { + [ anchor>> clone ] + [ tag>> clone ] + [ implicit>> ] + [ style>> ] + } cleave factor_mapping_start_event_data boa ; + : deep-copy-data ( event -- data ) [ data>> ] [ type>> ] bi { { YAML_SEQUENCE_START_EVENT [ sequence_start>> deep-copy-seq f ] } { YAML_MAPPING_START_EVENT [ mapping_start>> deep-copy-map f swap ] } } case factor_event_data boa ; + : deep-copy-event ( event -- event' ) - { [ type>> ] [ deep-copy-data ] [ start_mark>> ] [ end_mark>> ] } cleave - factor_yaml_event_t boa ; + { + [ type>> ] + [ deep-copy-data ] + [ start_mark>> ] + [ end_mark>> ] + } cleave factor_yaml_event_t boa ; : ?scalar-value ( event -- scalar/event scalar? ) dup type>> { @@ -92,12 +122,15 @@ TUPLE: factor_yaml_event_t type data start_mark end_mark ; DEFER: parse-sequence DEFER: parse-mapping + : (parse-sequence) ( parser event prev-event -- obj ) data>> sequence_start>> [ [ 2drop f ] dip ?register-anchor drop ] [ [ parse-sequence ] [ construct-sequence ] bi* ] [ 2nip ?register-anchor ] 3tri ; + : (parse-mapping) ( parser event prev-event -- obj ) data>> mapping_start>> [ [ 2drop f ] dip ?register-anchor drop ] [ [ parse-mapping ] [ construct-mapping ] bi* ] [ 2nip ?register-anchor ] 3tri ; + : next-complex-value ( parser event prev-event -- obj ) dup type>> { { YAML_SEQUENCE_START_EVENT [ (parse-sequence) ] } @@ -152,17 +185,20 @@ DEFER: parse-mapping ] with-destructors ; GENERIC: (deref-aliases) ( anchors obj -- obj' ) + M: object (deref-aliases) nip ; -M: byte-array (deref-aliases) nip ; -M: string (deref-aliases) nip ; + M: yaml-alias (deref-aliases) anchor>> swap at ; M: sequence (deref-aliases) [ (deref-aliases) ] with map! ; + M: set (deref-aliases) [ members (deref-aliases) ] [ clear-set ] [ swap union! ] tri ; + : assoc-map! ( assoc quot -- ) [ assoc-map ] [ drop clear-assoc ] [ drop swap assoc-union! ] 2tri ; inline + M: assoc (deref-aliases) swap '[ [ _ swap (deref-aliases) ] bi@ ] assoc-map! ; @@ -178,12 +214,11 @@ M: assoc (deref-aliases) { YAML_DOCUMENT_START_EVENT [ t ] } { YAML_STREAM_END_EVENT [ f ] } [ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } yaml-unexpected-event ] - } case - ] with-destructors - [ - parser event parse-yaml-doc t - parser event YAML_DOCUMENT_END_EVENT expect-event - ] [ f f ] if ; + } case [ + parser event parse-yaml-doc t + parser event YAML_DOCUMENT_END_EVENT expect-event + ] [ f f ] if + ] with-destructors ; ! registers destructors (use with with-destructors) :: init-parser ( str -- parser event ) @@ -217,14 +252,18 @@ PRIVATE> ( -- yaml-anchors ) IH{ } clone IH{ } clone 0 yaml-anchors boa ; + GENERIC: (replace-aliases) ( yaml-anchors obj -- obj' ) + : incr-anchor ( yaml-anchors -- current-anchor ) [ next-anchor>> ] [ [ [ number>string ] [ 1 + ] bi ] [ next-anchor<< ] bi* ] bi ; + :: ?replace-aliases ( yaml-anchors obj -- obj' ) yaml-anchors objects>> :> objects obj objects at* [ @@ -238,12 +277,17 @@ GENERIC: (replace-aliases) ( yaml-anchors obj -- obj' ) ] if ; M: object (replace-aliases) nip ; + M: byte-array (replace-aliases) nip ; + M: string (replace-aliases) nip ; M: sequence (replace-aliases) [ ?replace-aliases ] with map ; -M: set (replace-aliases) [ members (replace-aliases) ] keep set-like ; + +M: set (replace-aliases) + [ members (replace-aliases) ] keep set-like ; + M: assoc (replace-aliases) swap '[ [ _ swap ?replace-aliases ] bi@ ] assoc-map ; @@ -251,18 +295,28 @@ TUPLE: yaml-anchor anchor obj ; C: yaml-anchor GENERIC: (replace-anchors) ( yaml-anchors obj -- obj' ) -: (get-anchor) ( yaml-anchors obj -- anchor/f ) swap objects>> at ; + +: (get-anchor) ( yaml-anchors obj -- anchor/f ) + swap objects>> at ; + : get-anchor ( yaml-anchors obj -- anchor/f ) { [ (get-anchor) ] [ over new-objects>> at (get-anchor) ] } 2|| ; + : ?replace-anchors ( yaml-anchors obj -- obj' ) [ (replace-anchors) ] [ get-anchor ] 2bi [ swap ] when* ; + M: object (replace-anchors) nip ; + M: byte-array (replace-anchors) nip ; + M: string (replace-anchors) nip ; M: sequence (replace-anchors) [ ?replace-anchors ] with map ; -M: set (replace-anchors) [ members ?replace-anchors ] keep set-like ; + +M: set (replace-anchors) + [ members ?replace-anchors ] keep set-like ; + M: assoc (replace-anchors) swap '[ [ _ swap ?replace-anchors ] bi@ ] assoc-map ; @@ -281,6 +335,7 @@ SYMBOL: yaml-write-buffer ] yaml_write_handler_t ; GENERIC: emit-value ( emitter event anchor obj -- ) + : emit-object ( emitter event obj -- ) [ f ] dip emit-value ; :: emit-scalar ( emitter event anchor obj -- ) @@ -294,6 +349,7 @@ M: object emit-value ( emitter event anchor obj -- ) emit-scalar ; M: yaml-anchor emit-value ( emitter event unused obj -- ) nip [ anchor>> ] [ obj>> ] bi emit-value ; + M:: yaml-alias emit-value ( emitter event unused obj -- ) event obj anchor>> yaml_alias_event_initialize yaml-initialize-assert-ok emitter event yaml_emitter_emit_asserted ; @@ -309,20 +365,27 @@ M:: yaml-alias emit-value ( emitter event unused obj -- ) : emit-sequence-body ( emitter event seq -- ) [ emit-object ] with with each ; + : emit-assoc-body ( emitter event assoc -- ) >alist concat emit-sequence-body ; + : emit-linked-assoc-body ( emitter event linked-assoc -- ) >alist [ first2 swap associate ] map emit-sequence-body ; + : emit-set-body ( emitter event set -- ) [ members ] [ cardinality f ] bi zip concat emit-sequence-body ; M: f emit-value ( emitter event anchor f -- ) emit-scalar ; + M: string emit-value ( emitter event anchor string -- ) emit-scalar ; + M: byte-array emit-value ( emitter event anchor byte-array -- ) emit-scalar ; + M: sequence emit-value ( emitter event anchor seq -- ) [ drop YAML_SEQ_TAG emit-sequence-start ] [ nip emit-sequence-body ] [ 2drop emit-sequence-end ] 4tri ; + M: linked-assoc emit-value ( emitter event anchor assoc -- ) [ drop YAML_OMAP_TAG emit-sequence-start ] [ nip emit-linked-assoc-body ] @@ -341,6 +404,7 @@ M: assoc emit-value ( emitter event anchor assoc -- ) [ drop YAML_MAP_TAG emit-assoc-start ] [ nip emit-assoc-body ] [ 2drop emit-assoc-end ] 4tri ; + M: set emit-value ( emitter event anchor set -- ) [ drop YAML_SET_TAG emit-assoc-start ] [ nip emit-set-body ]