! Copyright (C) 2014 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors base64 byte-arrays combinators
-combinators.extras kernel math math.parser regexp sequences
-strings yaml.ffi ;
+USING: accessors assocs base64 byte-arrays combinators
+combinators.extras hash-sets kernel linked-assocs math
+math.parser regexp sequences strings yaml.ffi ;
IN: yaml.conversion
! !!!!!!!!!!!!!!
{ 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-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
GENERIC: represent-scalar ( obj -- str )
! Copyright (C) 2014 Jon Harper.
! 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
! TODO real conformance tests here
! !!!!!!!!!!!!!!!
! construct-set
-! TODO implement this to hash-set
-! CONSTANT: construct-set-obj H{
-! {
-! "baseball players" HS{
-! "Mark McGwire"
-! "Sammy Sosa"
-! "Ken Griffey"
-! }
-! } {
-! "baseball teams" HS{
-! "Boston Red Sox"
-! "Detroit Tigers"
-! "New York Yankees"
-! }
-! }
-! }
-!
-! CONSTANT: construct-set-str """# Explicitly typed set.
-! baseball players: !!set
-! ? Mark McGwire
-! ? Sammy Sosa
-! ? Ken Griffey
-! # Flow style
-! 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-obj >yaml yaml> ] unit-test
+CONSTANT: construct-set-obj H{
+ {
+ "baseball players" HS{
+ "Mark McGwire"
+ "Sammy Sosa"
+ "Ken Griffey"
+ }
+ } {
+ "baseball teams" HS{
+ "Boston Red Sox"
+ "Detroit Tigers"
+ "New York Yankees"
+ }
+ }
+}
+
+CONSTANT: construct-set-str """# Explicitly typed set.
+baseball players: !!set
+ ? Mark McGwire
+ ? Sammy Sosa
+ ? Ken Griffey
+# Flow style
+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-obj >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!!
! construct-binary
! !!!!!!!!!!!!!!!
! construct-omap
-! TODO what to do with omap ?
-! CONSTANT: construct-omap-obj f
-!
-! 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
+CONSTANT: construct-omap-obj H{
+ {
+ "Bestiary"
+ $[ <linked-hash> {
+ { "aardvark" "African pig-like ant eater. Ugly." }
+ { "anteater" "South-American ant eater. Two species." }
+ { "anaconda" "South-American constrictor snake. Scaly." }
+ } assoc-union! ]
+ } {
+ "Numbers"
+ $[ <linked-hash> {
+ { "one" 1 }
+ { "two" 2 }
+ { "three" 3 }
+ } 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
-! TODO what to do with pairs ?
-! CONSTANT: construct-pairs-obj f
-!
-! 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 ]
-! """
-!
-! ${ construct-pairs-obj } [ $ construct-pairs-str yaml> ] unit-test
-! ${ construct-pairs-obj } [ $ construct-pairs-obj >yaml yaml> ] unit-test
+CONSTANT: construct-pairs-obj H{
+ {
+ "Block tasks" {
+ { "meeting" "with team." }
+ { "meeting" "with boss." }
+ { "break" "lunch." }
+ { "meeting" "with client." }
+ }
+ } {
+ "Flow tasks" {
+ { "meeting" "with team" } { "meeting" "with boss" }
+ }
+ }
+}
+
+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
! Copyright (C) 2013 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.data assocs byte-arrays classes.struct
-combinators destructors io.encodings.string io.encodings.utf8
-kernel libc locals make namespaces sequences strings yaml.ffi
-yaml.conversion ;
+USING: accessors alien.data arrays assocs byte-arrays
+classes.struct combinators destructors hashtables
+io.encodings.string io.encodings.utf8 kernel libc linked-assocs
+locals make namespaces sequences sets strings yaml.conversion
+yaml.ffi ;
+FROM: sets => set ;
IN: yaml
<PRIVATE
DEFER: parse-sequence
DEFER: parse-mapping
: (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 ] [ 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 )
dup type>> {
- { YAML_SEQUENCE_START_EVENT [ data>> (parse-sequence) ] }
- { YAML_MAPPING_START_EVENT [ data>> (parse-mapping) ] }
+ { YAML_SEQUENCE_START_EVENT [ (parse-sequence) ] }
+ { YAML_MAPPING_START_EVENT [ (parse-mapping) ] }
{ YAML_ALIAS_EVENT [ 2nip deref-anchor ] }
[ throw ]
} case ;
] until
] H{ } make ;
-:: parse-sequence ( parser event -- seq )
+:: parse-sequence ( parser event -- seq )
[
f :> done!
[ done ] [
M: object emit-value ( emitter event obj -- ) emit-scalar ;
-:: emit-sequence-start ( emitter event -- )
- event f YAML_SEQ_TAG f YAML_ANY_SEQUENCE_STYLE
+:: emit-sequence-start ( emitter event tag -- )
+ event f tag f YAML_ANY_SEQUENCE_STYLE
yaml_sequence_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok ;
: emit-sequence ( emitter event seq -- )
[ 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: byte-array emit-value ( emitter event seq -- ) emit-scalar ;
M: sequence emit-value ( emitter event seq -- )
- [ drop emit-sequence-start ]
+ [ drop YAML_SEQ_TAG emit-sequence-start ]
[ emit-sequence ]
[ 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 -- )
- event f YAML_MAP_TAG f YAML_ANY_MAPPING_STYLE
+:: emit-assoc-start ( emitter event tag -- )
+ event f tag f YAML_ANY_MAPPING_STYLE
yaml_mapping_start_event_initialize yaml-assert-ok
emitter event 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 ;
-
M: assoc emit-value ( emitter event seq -- )
- [ drop emit-assoc-start ]
+ [ drop YAML_MAP_TAG emit-assoc-start ]
[ emit-assoc ]
[ 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)
:: init-emitter ( -- emitter event )
projects / factor.git / commitdiff