From 2db5962cc39bce5f22cdcacc1584bc50fbe3b55e Mon Sep 17 00:00:00 2001 From: Jon Harper Date: Tue, 25 Mar 2014 18:51:37 +0100 Subject: [PATCH] YAML: support !!set, !!omap and !!pair --- extra/yaml/conversion/conversion.factor | 25 +++- extra/yaml/yaml-tests.factor | 157 +++++++++++++++--------- extra/yaml/yaml.factor | 51 +++++--- 3 files changed, 154 insertions(+), 79 deletions(-) diff --git a/extra/yaml/conversion/conversion.factor b/extra/yaml/conversion/conversion.factor index 9dce35b031..8d52a71dd7 100644 --- a/extra/yaml/conversion/conversion.factor +++ b/extra/yaml/conversion/conversion.factor @@ -1,8 +1,8 @@ ! 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 ! !!!!!!!!!!!!!! @@ -76,6 +76,25 @@ CONSTANT: YAML_BINARY_TAG "tag:yaml.org,2002:binary" { 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-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 ) diff --git a/extra/yaml/yaml-tests.factor b/extra/yaml/yaml-tests.factor index 3a80f104a6..55d9ed8a22 100644 --- a/extra/yaml/yaml-tests.factor +++ b/extra/yaml/yaml-tests.factor @@ -1,6 +1,6 @@ ! 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 @@ -225,34 +225,33 @@ ${ construct-seq-obj } [ $ construct-seq-obj >yaml yaml> ] unit-test ! !!!!!!!!!!!!!!! ! 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 @@ -370,38 +369,80 @@ ${ construct-binary-obj } [ $ construct-binary-obj >yaml yaml> ] unit-test ! !!!!!!!!!!!!!!! ! 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" + $[ { + { "aardvark" "African pig-like ant eater. Ugly." } + { "anteater" "South-American ant eater. Two species." } + { "anaconda" "South-American constrictor snake. Scaly." } + } assoc-union! ] + } { + "Numbers" + $[ { + { "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 diff --git a/extra/yaml/yaml.factor b/extra/yaml/yaml.factor index 0ee2922024..f2d97e1937 100644 --- a/extra/yaml/yaml.factor +++ b/extra/yaml/yaml.factor @@ -1,9 +1,11 @@ ! 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 > ?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 ; @@ -90,7 +94,7 @@ DEFER: parse-mapping ] until ] H{ } make ; -:: parse-sequence ( parser event -- seq ) +:: parse-sequence ( parser event -- seq ) [ f :> done! [ done ] [ @@ -185,8 +189,8 @@ GENERIC: emit-value ( emitter event obj -- ) 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 ; @@ -196,16 +200,26 @@ M: object emit-value ( emitter event obj -- ) emit-scalar ; : 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 ] 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 ; @@ -213,13 +227,14 @@ M: sequence emit-value ( emitter event seq -- ) 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 )