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

YAML: support !!set, !!omap and !!pair

db4
Jon Harper 2014-03-25 18:51:37 +01:00 committed by John Benediktsson
parent c7613e62a0
commit 2db5962cc3
3 changed files with 154 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,8 +1,8 @@
! Copyright (C) 2014 Jon Harper. ! Copyright (C) 2014 Jon Harper.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors base64 byte-arrays combinators USING: accessors assocs base64 byte-arrays combinators
combinators.extras kernel math math.parser regexp sequences combinators.extras hash-sets kernel linked-assocs math
strings yaml.ffi ; math.parser regexp sequences strings yaml.ffi ;
IN: yaml.conversion IN: yaml.conversion
! !!!!!!!!!!!!!! ! !!!!!!!!!!!!!!
@ -76,6 +76,25 @@ CONSTANT: YAML_BINARY_TAG "tag:yaml.org,2002:binary"
{ YAML_STR_TAG [ ] } { YAML_STR_TAG [ ] }
} case ; } 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-sequence ( obj prev-event -- obj' )
tag>> {
{ YAML_OMAP_TAG [ construct-omap ] }
{ YAML_PAIRS_TAG [ construct-pairs ] }
[ drop ]
} case ;
CONSTANT: YAML_SET_TAG "tag:yaml.org,2002:set"
: construct-set ( obj -- obj' ) keys >hash-set ;
: construct-mapping ( obj prev-event -- obj' )
tag>> {
{ YAML_SET_TAG [ construct-set ] }
[ drop ]
} case ;
! !!!!!!!!!!!!!! ! !!!!!!!!!!!!!!
! factor -> yaml ! factor -> yaml
GENERIC: represent-scalar ( obj -- str ) GENERIC: represent-scalar ( obj -- str )

157
extra/yaml/yaml-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2014 Jon Harper. ! Copyright (C) 2014 Jon Harper.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: literals tools.test yaml ; USING: assocs linked-assocs literals tools.test yaml ;
IN: yaml.tests IN: yaml.tests
! TODO real conformance tests here ! TODO real conformance tests here
@ -225,34 +225,33 @@ ${ construct-seq-obj } [ $ construct-seq-obj >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!
! construct-set ! construct-set
! TODO implement this to hash-set CONSTANT: construct-set-obj H{
! CONSTANT: construct-set-obj H{ {
! { "baseball players" HS{
! "baseball players" HS{ "Mark McGwire"
! "Mark McGwire" "Sammy Sosa"
! "Sammy Sosa" "Ken Griffey"
! "Ken Griffey" }
! } } {
! } { "baseball teams" HS{
! "baseball teams" HS{ "Boston Red Sox"
! "Boston Red Sox" "Detroit Tigers"
! "Detroit Tigers" "New York Yankees"
! "New York Yankees" }
! } }
! } }
! }
! CONSTANT: construct-set-str """# Explicitly typed set.
! CONSTANT: construct-set-str """# Explicitly typed set. baseball players: !!set
! baseball players: !!set ? Mark McGwire
! ? Mark McGwire ? Sammy Sosa
! ? Sammy Sosa ? Ken Griffey
! ? Ken Griffey # Flow style
! # Flow style baseball teams: !!set { Boston Red Sox, Detroit Tigers, New York Yankees }
! baseball teams: !!set { Boston Red Sox, Detroit Tigers, New York Yankees } """
! """
! ${ construct-set-obj } [ $ construct-set-str yaml> ] unit-test
! ${ construct-set-obj } [ $ construct-set-str yaml> ] unit-test ${ construct-set-obj } [ $ construct-set-obj >yaml yaml> ] unit-test
! ${ construct-set-obj } [ $ construct-set-obj >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!
! construct-binary ! construct-binary
@ -370,38 +369,80 @@ ${ construct-binary-obj } [ $ construct-binary-obj >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!
! construct-omap ! construct-omap
! TODO what to do with omap ? CONSTANT: construct-omap-obj H{
! CONSTANT: construct-omap-obj f {
! "Bestiary"
! CONSTANT: construct-omap-str """# Explicitly typed ordered map (dictionary). $[ <linked-hash> {
! Bestiary: !!omap { "aardvark" "African pig-like ant eater. Ugly." }
! - aardvark: African pig-like ant eater. Ugly. { "anteater" "South-American ant eater. Two species." }
! - anteater: South-American ant eater. Two species. { "anaconda" "South-American constrictor snake. Scaly." }
! - anaconda: South-American constrictor snake. Scaly. } assoc-union! ]
! # Etc. } {
! # Flow style "Numbers"
! Numbers: !!omap [ one: 1, two: 2, three : 3 ] $[ <linked-hash> {
! """ { "one" 1 }
! { "two" 2 }
! ${ construct-omap-obj } [ $ construct-omap-str yaml> ] unit-test { "three" 3 }
! ${ construct-omap-obj } [ $ construct-omap-obj >yaml yaml> ] unit-test } assoc-union! ]
}
}
CONSTANT: construct-omap-str """# Explicitly typed ordered map (dictionary).
Bestiary: !!omap
- aardvark: African pig-like ant eater. Ugly.
- anteater: South-American ant eater. Two species.
- anaconda: South-American constrictor snake. Scaly.
# Etc.
# Flow style
Numbers: !!omap [ one: 1, two: 2, three : 3 ]
"""
${ construct-omap-obj } [ $ construct-omap-str yaml> ] unit-test
${ construct-omap-obj } [ $ construct-omap-obj >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!
! construct-pairs ! construct-pairs
! TODO what to do with pairs ? CONSTANT: construct-pairs-obj H{
! CONSTANT: construct-pairs-obj f {
! "Block tasks" {
! CONSTANT: construct-pairs-str """# Explicitly typed pairs. { "meeting" "with team." }
! Block tasks: !!pairs { "meeting" "with boss." }
! - meeting: with team. { "break" "lunch." }
! - meeting: with boss. { "meeting" "with client." }
! - break: lunch. }
! - meeting: with client. } {
! Flow tasks: !!pairs [ meeting: with team, meeting: with boss ] "Flow tasks" {
! """ { "meeting" "with team" } { "meeting" "with boss" }
! }
! ${ construct-pairs-obj } [ $ construct-pairs-str yaml> ] unit-test }
! ${ construct-pairs-obj } [ $ construct-pairs-obj >yaml yaml> ] unit-test }
CONSTANT: construct-pairs-str """# Explicitly typed pairs.
Block tasks: !!pairs
- meeting: with team.
- meeting: with boss.
- break: lunch.
- meeting: with client.
Flow tasks: !!pairs [ meeting: with team, meeting: with boss ]
"""
CONSTANT: construct-pairs-obj-roundtripped H{
{
"Block tasks" {
H{ { "meeting" "with team." } }
H{ { "meeting" "with boss." } }
H{ { "break" "lunch." } }
H{ { "meeting" "with client." } }
}
} {
"Flow tasks" {
H{ { "meeting" "with team" } } H{ { "meeting" "with boss" } }
}
}
}
${ construct-pairs-obj } [ $ construct-pairs-str yaml> ] unit-test
${ construct-pairs-obj } [ $ construct-pairs-obj >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!
! construct-timestamp ! construct-timestamp

51
extra/yaml/yaml.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2013 Jon Harper. ! Copyright (C) 2013 Jon Harper.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.data assocs byte-arrays classes.struct USING: accessors alien.data arrays assocs byte-arrays
combinators destructors io.encodings.string io.encodings.utf8 classes.struct combinators destructors hashtables
kernel libc locals make namespaces sequences strings yaml.ffi io.encodings.string io.encodings.utf8 kernel libc linked-assocs
yaml.conversion ; locals make namespaces sequences sets strings yaml.conversion
yaml.ffi ;
FROM: sets => set ;
IN: yaml IN: yaml
<PRIVATE <PRIVATE
@ -56,13 +58,15 @@ TUPLE: factor_yaml_event_t type data start_mark end_mark ;
DEFER: parse-sequence DEFER: parse-sequence
DEFER: parse-mapping DEFER: parse-mapping
: (parse-sequence) ( parser event prev-event -- obj ) : (parse-sequence) ( parser event prev-event -- obj )
[ parse-sequence ] [ sequence_start>> ?register-anchor ] bi* ; data>> sequence_start>>
[ [ parse-sequence ] [ construct-sequence ] bi* ] [ 2nip ?register-anchor ] 3bi ;
: (parse-mapping) ( parser event prev-event -- obj ) : (parse-mapping) ( parser event prev-event -- obj )
[ parse-mapping ] [ mapping_start>> ?register-anchor ] bi* ; data>> mapping_start>>
[ [ parse-mapping ] [ construct-mapping ] bi* ] [ 2nip ?register-anchor ] 3bi ;
: next-complex-value ( parser event prev-event -- obj ) : next-complex-value ( parser event prev-event -- obj )
dup type>> { dup type>> {
{ YAML_SEQUENCE_START_EVENT [ data>> (parse-sequence) ] } { YAML_SEQUENCE_START_EVENT [ (parse-sequence) ] }
{ YAML_MAPPING_START_EVENT [ data>> (parse-mapping) ] } { YAML_MAPPING_START_EVENT [ (parse-mapping) ] }
{ YAML_ALIAS_EVENT [ 2nip deref-anchor ] } { YAML_ALIAS_EVENT [ 2nip deref-anchor ] }
[ throw ] [ throw ]
} case ; } case ;
@ -90,7 +94,7 @@ DEFER: parse-mapping
] until ] until
] H{ } make ; ] H{ } make ;
:: parse-sequence ( parser event -- seq ) :: parse-sequence ( parser event -- seq )
[ [
f :> done! f :> done!
[ done ] [ [ done ] [
@ -185,8 +189,8 @@ GENERIC: emit-value ( emitter event obj -- )
M: object emit-value ( emitter event obj -- ) emit-scalar ; M: object emit-value ( emitter event obj -- ) emit-scalar ;
:: emit-sequence-start ( emitter event -- ) :: emit-sequence-start ( emitter event tag -- )
event f YAML_SEQ_TAG f YAML_ANY_SEQUENCE_STYLE event f tag f YAML_ANY_SEQUENCE_STYLE
yaml_sequence_start_event_initialize yaml-assert-ok yaml_sequence_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok ; emitter event yaml_emitter_emit yaml-assert-ok ;
@ -196,16 +200,26 @@ M: object emit-value ( emitter event obj -- ) emit-scalar ;
: emit-sequence ( emitter event seq -- ) : emit-sequence ( emitter event seq -- )
[ emit-value ] with with each ; [ emit-value ] with with each ;
: emit-assoc ( emitter event assoc -- )
>alist concat emit-sequence ;
: emit-linked-assoc ( emitter event linked-assoc -- )
>alist [ first2 swap associate ] map emit-sequence ;
: emit-set ( emitter event set -- )
[ members ] [ cardinality f <array> ] bi zip concat emit-sequence ;
M: string emit-value ( emitter event seq -- ) emit-scalar ; M: string emit-value ( emitter event seq -- ) emit-scalar ;
M: byte-array emit-value ( emitter event seq -- ) emit-scalar ; M: byte-array emit-value ( emitter event seq -- ) emit-scalar ;
M: sequence emit-value ( emitter event seq -- ) M: sequence emit-value ( emitter event seq -- )
[ drop emit-sequence-start ] [ drop YAML_SEQ_TAG emit-sequence-start ]
[ emit-sequence ] [ emit-sequence ]
[ drop emit-sequence-end ] 3tri ; [ drop emit-sequence-end ] 3tri ;
M: linked-assoc emit-value ( emitter event assoc -- )
[ drop YAML_OMAP_TAG emit-sequence-start ]
[ emit-linked-assoc ]
[ drop emit-sequence-end ] 3tri ;
:: emit-assoc-start ( emitter event -- ) :: emit-assoc-start ( emitter event tag -- )
event f YAML_MAP_TAG f YAML_ANY_MAPPING_STYLE event f tag f YAML_ANY_MAPPING_STYLE
yaml_mapping_start_event_initialize yaml-assert-ok yaml_mapping_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok ; emitter event yaml_emitter_emit yaml-assert-ok ;
@ -213,13 +227,14 @@ M: sequence emit-value ( emitter event seq -- )
dup yaml_mapping_end_event_initialize yaml-assert-ok dup yaml_mapping_end_event_initialize yaml-assert-ok
yaml_emitter_emit yaml-assert-ok ; yaml_emitter_emit yaml-assert-ok ;
: emit-assoc ( emitter event assoc -- )
[ [ emit-value ] with with bi@ ] with with assoc-each ;
M: assoc emit-value ( emitter event seq -- ) M: assoc emit-value ( emitter event seq -- )
[ drop emit-assoc-start ] [ drop YAML_MAP_TAG emit-assoc-start ]
[ emit-assoc ] [ emit-assoc ]
[ drop emit-assoc-end ] 3tri ; [ drop emit-assoc-end ] 3tri ;
M: set emit-value ( emitter event set -- )
[ drop YAML_SET_TAG emit-assoc-start ]
[ emit-set ]
[ drop emit-assoc-end ] 3tri ;
! registers destructors (use with with-destructors) ! registers destructors (use with with-destructors)
:: init-emitter ( -- emitter event ) :: init-emitter ( -- emitter event )