! 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 ;
! !!!!!!!!!!!!!!
! 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' ) <linked-hash> [ assoc-union! ] reduce ;
+: construct-pairs ( obj -- obj' )
+ [ >alist first ] map ;
+
+: construct-omap ( obj -- obj' )
+ <linked-hash> [ assoc-union! ] reduce ;
+
: construct-sequence ( obj prev-event -- obj' )
tag>> {
{ YAML_OMAP_TAG [ construct-omap ] }
[ 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 ] }
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 ;
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 . ;
-:: yaml-events ( string -- )
-[
-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
+ 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_event_t (malloc-struct) &free :> event
+:: yaml-events ( string -- )
+ [
+ yaml_parser_t (malloc-struct) &free &yaml_parser_delete :> parser
+ parser yaml_parser_initialize .
-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
+ string utf8 encode [ malloc-byte-array &free ] [ length ] bi :> ( input length )
+ parser input length yaml_parser_set_input_string
-] with-destructors
+ 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
+ ] 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 <process-reader> stream-lines [ string>number ] map ;
+: c-struct-sizes ( -- sizes )
+ "vocab:yaml/dbg/structs" normalize-path
+ ascii <process-reader> 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 . . ;
<PRIVATE
-: yaml-initialize-assert-ok ( ? -- ) [ libyaml-initialize-error ] unless ;
+: yaml-initialize-assert-ok ( ? -- )
+ [ libyaml-initialize-error ] unless ;
+
: (libyaml-parser-error) ( parser -- )
{
- [ error>> ] [ 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> 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 ;
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>> {
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) ] }
] 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! ;
{ 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 )
<PRIVATE
TUPLE: yaml-anchors objects new-objects next-anchor ;
+
: <yaml-anchors> ( -- 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* [
] 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 ;
C: <yaml-anchor> 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 <yaml-anchor> ] 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 ;
] 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 -- )
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 ;
: 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 <array> ] 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 ]
[ 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 ]
projects / factor.git / commitdiff