steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

yaml: some formatting/cleanup.

db4
John Benediktsson 2014-04-27 15:41:24 -07:00
parent 1d38dce342
commit 72efd16074
3 changed files with 227 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
extra/yaml/conversion/conversion.factor
View File

@ -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' ) <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 ] }
@ -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 ;

181
extra/yaml/dbg/dbg.factor
View File

@ -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 <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 . . ;

104
extra/yaml/yaml.factor
View File

@ -22,29 +22,43 @@ ERROR: yaml-no-document ;
<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 ;
@ -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>
<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* [
@ -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> 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 ;
@ -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 <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 ]
@ -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 ]