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

YAML: support !!merge in !!map

db4
Jon Harper 2014-06-01 19:54:44 +02:00 committed by John Benediktsson
parent 640975bdc2
commit e1e2519d7a
4 changed files with 211 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/yaml/conversion/conversion-tests.factor
View File

@ -4,9 +4,9 @@ USING: kernel literals sequences tools.test yaml.conversion
yaml.ffi ;
IN: yaml.conversion.tests
: resolve-test ( res str -- ) [ resolve-plain-scalar ] curry unit-test ;
: resolve-test ( res str -- ) [ f resolve-plain-scalar ] curry unit-test ;
: resolve-tests ( res seq -- ) [
[ resolve-plain-scalar ] curry unit-test
[ f resolve-plain-scalar ] curry unit-test
] with each ;
${ YAML_NULL_TAG } "null" resolve-test
@ -24,3 +24,5 @@ ${ YAML_TIMESTAMP_TAG } {
"2002-12-14"
"2001-2-4 \t\t 1:59:43.10 \t\t -5:00"
} resolve-tests
${ YAML_STR_TAG } "<<" resolve-test
${ YAML_MERGE_TAG } [ "<<" t resolve-plain-scalar ] unit-test

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

@ -6,6 +6,9 @@ math.parser regexp sequences strings yaml.ffi
calendar calendar.format ;
IN: yaml.conversion
! http://yaml.org/type/
CONSTANT: YAML_MERGE_TAG "tag:yaml.org,2002:merge"
! !!!!!!!!!!!!!!
! tag resolution
! http://www.yaml.org/spec/1.2/spec.html
@ -22,7 +25,7 @@ CONSTANT: re-infinity R/ [-+]?\.(inf|Inf|INF)/
CONSTANT: re-nan R/ \.(nan|NaN|NAN)/
CONSTANT: re-timestamp R/ [0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]|[0-9][0-9][0-9][0-9]-[0-9][0-9]?-[0-9][0-9]?([Tt]|[ \t]+)[0-9][0-9]?:[0-9][0-9]:[0-9][0-9](\.[0-9]*)?([ \t]*(Z|[-+][0-9][0-9]?(:[0-9][0-9])?))?/
: resolve-plain-scalar ( str -- tag )
: resolve-normal-plain-scalar ( str -- tag )
{
{ [ re-null matches? ] [ YAML_NULL_TAG ] }
{ [ re-empty matches? ] [ YAML_NULL_TAG ] }
@ -37,6 +40,21 @@ CONSTANT: re-timestamp R/ [0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]|[0-9][0-9][
[ drop YAML_STR_TAG ]
} cond-case ;
CONSTANT: re-merge R/ <</
: (resolve-mapping-key-plain-scalar) ( str -- tag )
{
{ [ re-merge matches? ] [ YAML_MERGE_TAG ] }
[ drop YAML_STR_TAG ]
} cond-case ;
: resolve-mapping-key-plain-scalar ( str -- tag )
dup resolve-normal-plain-scalar dup YAML_STR_TAG = [
drop (resolve-mapping-key-plain-scalar)
] [ nip ] if ;
: resolve-plain-scalar ( str mapping-key? -- tag )
[ resolve-mapping-key-plain-scalar ] [ resolve-normal-plain-scalar ] if ;
CONSTANT: NON-SPECIFIC-TAG "!"
: resolve-explicit-tag ( tag default-tag -- tag )
@ -51,11 +69,11 @@ CONSTANT: NON-SPECIFIC-TAG "!"
: resolve-explicit-mapping-tag ( tag -- tag )
YAML_DEFAULT_MAPPING_TAG resolve-explicit-tag ;
: resolve-scalar ( scalar-event -- tag )
: resolve-scalar ( scalar-event mapping-key? -- tag )
{
{ [ dup tag>> ] [ tag>> resolve-explicit-scalar-tag ] }
{ [ dup style>> YAML_PLAIN_SCALAR_STYLE = not ] [ drop YAML_STR_TAG ] }
[ value>> resolve-plain-scalar ]
{ [ over tag>> ] [ drop tag>> resolve-explicit-scalar-tag ] }
{ [ over style>> YAML_PLAIN_SCALAR_STYLE = not ] [ 2drop YAML_STR_TAG ] }
[ [ value>> ] dip resolve-plain-scalar ]
} cond ;
! !!!!!!!!!!!!!!
@ -96,14 +114,18 @@ CONSTANT: YAML_SET_TAG "tag:yaml.org,2002:set"
dup R/ [0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]/ matches?
[ ymd>timestamp ] [ yaml>rfc3339 rfc3339>timestamp ] if ;
: construct-scalar ( scalar-event -- scalar )
[ value>> ] [ resolve-scalar ] bi {
TUPLE: yaml-merge ;
C: <yaml-merge> yaml-merge
: construct-scalar ( scalar-event mapping-key? -- scalar )
[ drop value>> ] [ resolve-scalar ] 2bi {
{ 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_TIMESTAMP_TAG [ construct-timestamp ] }
{ YAML_MERGE_TAG [ drop <yaml-merge> ] }
{ YAML_STR_TAG [ ] }
} case ;
@ -151,3 +173,6 @@ M: byte-array yaml-tag ( obj -- tag ) drop YAML_BINARY_TAG ;
M: timestamp represent-scalar ( obj -- str ) timestamp>rfc3339 ;
M: timestamp yaml-tag ( obj -- str ) drop YAML_TIMESTAMP_TAG ;
M: yaml-merge represent-scalar ( obj -- str ) drop "<<" ;
M: yaml-merge yaml-tag ( obj -- str ) drop YAML_MERGE_TAG ;

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs grouping kernel linked-assocs literals locals
namespaces sequences tools.test yaml yaml.config yaml.ffi
yaml.private calendar ;
yaml.private calendar yaml.conversion ;
IN: yaml.tests
! TODO real conformance tests here
@ -403,49 +403,123 @@ ${ construct-binary-obj } [ $ construct-binary-obj >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!!
! construct-merge
! TODO decide when to merge
! CONSTANT: construct-merge-obj {
! H{ { "x" 1 } { "y" 2 } }
! H{ { "x" 0 } { "y" 2 } }
! H{ { "r" 10 } }
! H{ { "r" 1 } }
! H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
! H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
! H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
! H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
! }
!
! CONSTANT: construct-merge-str """---
! - &CENTER { x: 1, 'y': 2 }
! - &LEFT { x: 0, 'y': 2 }
! - &BIG { r: 10 }
! - &SMALL { r: 1 }
!
! # All the following maps are equal:
!
! - # Explicit keys
! x: 1
! 'y': 2
! r: 10
! label: center/big
!
! - # Merge one map
! << : *CENTER
! r: 10
! label: center/big
!
! - # Merge multiple maps
! << : [ *CENTER, *BIG ]
! label: center/big
!
! - # Override
! << : [ *BIG, *LEFT, *SMALL ]
! x: 1
! label: center/big
! """
!
! ${ construct-merge-obj } [ $ construct-merge-str yaml> ] unit-test
! ${ construct-merge-obj } [ $ construct-merge-obj >yaml yaml> ] unit-test
CONSTANT: construct-merge-obj {
H{ { "x" 1 } { "y" 2 } }
H{ { "x" 0 } { "y" 2 } }
H{ { "r" 10 } }
H{ { "r" 1 } }
H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
}
:: construct-merge-obj2 ( -- obj )
H{ { "x" 1 } { "y" 2 } } :> CENTER
H{ { "x" 0 } { "y" 2 } } :> LEFT
H{ { "r" 10 } } :> BIG
H{ { "r" 1 } } :> SMALL
{
CENTER
LEFT
BIG
SMALL
H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
H{ { T{ yaml-merge } CENTER } { "r" 10 } { "label" "center/big" } }
H{ { T{ yaml-merge } { CENTER BIG } } { "label" "center/big" } }
H{ { T{ yaml-merge } { BIG LEFT SMALL } } { "x" 1 } { "label" "center/big" } }
} ;
CONSTANT: construct-merge-str """---
- &CENTER { x: 1, 'y': 2 }
- &LEFT { x: 0, 'y': 2 }
- &BIG { r: 10 }
- &SMALL { r: 1 }
# All the following maps are equal:
- # Explicit keys
x: 1
'y': 2
r: 10
label: center/big
- # Merge one map
<< : *CENTER
r: 10
label: center/big
- # Merge multiple maps
<< : [ *CENTER, *BIG ]
label: center/big
- # Override
<< : [ *BIG, *LEFT, *SMALL ]
x: 1
label: center/big
"""
${ construct-merge-obj } [ $ construct-merge-str yaml> ] unit-test
${ construct-merge-obj } [ $ construct-merge-obj2 >yaml yaml> ] unit-test
! More merge tests
! see http://sourceforge.net/p/yaml/mailman/message/12308050
CONSTANT: nested-merge-str "foo: 1
<<:
bar: 2
<<:
baz: 3"
CONSTANT: nested-merge-obj H{
{ "foo" 1 }
{ "bar" 2 }
{ "baz" 3 }
}
${ nested-merge-obj } [ $ nested-merge-str yaml> ] unit-test
${ nested-merge-obj } [ $ nested-merge-obj >yaml yaml> ] unit-test
CONSTANT: recursive-merge-str "--- &A
<<: *A"
CONSTANT: recursive-merge-obj H{ }
${ recursive-merge-obj } [ $ recursive-merge-str yaml> ] unit-test
${ recursive-merge-obj } [ $ recursive-merge-obj >yaml yaml> ] unit-test
! Compare with pyyaml
! >>> print yaml.load("&1 {1: 2, 2: 3, 3: {4: 5, <<: *1}}")
! {1: 2, 2: 3, 3: {1: 2, 2: 3, 3: {...}, 4: 5}}
! >>> print yaml.load("&1 {1: 2, 2: 3, 3: {3: 100, 4: 5, <<: *1}}")
! {1: 2, 2: 3, 3: {1: 2, 2: 3, 3: 100, 4: 5}}
CONSTANT: recursive-merge-str2 "&1 {1: 2, 2: 3, 3: {4: 5, <<: *1}}"
CONSTANT: recursive-merge-str3 "&1 {1: 2, 2: 3, 3: {3: 100, 4: 5, <<: *1}}"
:: recursive-merge-obj2 ( -- obj ) H{ } clone :> inner
inner H{
{ 1 2 }
{ 2 3 }
{ 3 inner }
{ 4 5 }
} assoc-union! drop
H{
{ 1 2 }
{ 2 3 }
{ 3 inner }
} ;
CONSTANT: recursive-merge-obj3 H{
{ 1 2 }
{ 2 3 }
{ 3 H{ { 1 2 } { 2 3 } { 3 100 } { 4 5 } } }
}
{ t } [
$ recursive-merge-str2 yaml> recursive-merge-obj2
[ replace-identities ] bi@ =
] unit-test
{ t } [
recursive-merge-obj2 >yaml yaml> recursive-merge-obj2
[ replace-identities ] bi@ =
] unit-test
${ recursive-merge-obj3 } [ $ recursive-merge-str3 yaml> ] unit-test
${ recursive-merge-obj3 } [ $ recursive-merge-obj3 >yaml yaml> ] unit-test
! !!!!!!!!!!!!!!!
! construct-omap

71
extra/yaml/yaml.factor
View File

@ -6,7 +6,7 @@ combinators.short-circuit destructors fry generalizations
hashtables hashtables.identity io.encodings.string
io.encodings.utf8 kernel libc linked-assocs locals make math
math.parser namespaces sequences sets strings yaml.config
yaml.conversion yaml.ffi ;
yaml.conversion yaml.ffi hash-sets.identity ;
FROM: sets => set ;
IN: yaml
@ -68,9 +68,9 @@ SYMBOL: anchors
[ assert-anchor-exists ]
[ <yaml-alias> ] bi ;
: event>scalar ( event -- obj )
: event>scalar ( mapping-key? event -- obj )
data>> scalar>>
[ construct-scalar ]
[ swap construct-scalar ]
[ ?register-anchor ] bi ;
! TODO simplify this ?!?
@ -109,12 +109,14 @@ TUPLE: factor_yaml_event_t type data start_mark end_mark ;
[ end_mark>> ]
} cleave factor_yaml_event_t boa ;
: ?scalar-value ( event -- scalar/event scalar? )
: (?scalar-value) ( mapping-key? event -- scalar/event scalar? )
dup type>> {
{ YAML_SCALAR_EVENT [ event>scalar t ] }
{ YAML_ALIAS_EVENT [ deref-anchor t ] }
[ drop deep-copy-event f ]
{ YAML_ALIAS_EVENT [ nip deref-anchor t ] }
[ drop nip deep-copy-event f ]
} case ;
: ?mapping-key-scalar-value ( event -- scalar/event scalar? ) t swap (?scalar-value) ;
: ?scalar-value ( event -- scalar/event scalar? ) f swap (?scalar-value) ;
! Must not reuse the event struct before with-destructors scope ends
: next-event ( parser event -- event )
@ -150,7 +152,7 @@ DEFER: parse-mapping
YAML_MAPPING_END_EVENT = [
t done! f f
] [
event ?scalar-value
event ?mapping-key-scalar-value
] if
] with-destructors
done [ 2drop ] [
@ -184,6 +186,11 @@ DEFER: parse-mapping
[ 2drop ] [ 1array yaml-unexpected-event ] if
] with-destructors ;
! Same as 'with', but for combinators that
! put 2 arguments on the stack
: with2 ( param obj quot -- obj curry )
swapd '[ [ _ ] 2dip @ ] ; inline
GENERIC: (deref-aliases) ( anchors obj -- obj' )
M: object (deref-aliases) nip ;
@ -200,16 +207,40 @@ M: sequence (deref-aliases)
M: set (deref-aliases)
[ members (deref-aliases) ] [ clear-set ] [ swap union! ] tri ;
: assoc-map! ( assoc quot -- )
: assoc-map! ( assoc quot -- assoc' )
[ assoc-map ] [ drop clear-assoc ] [ drop swap assoc-union! ] 2tri ; inline
M: assoc (deref-aliases)
swap '[ [ _ swap (deref-aliases) ] bi@ ] assoc-map! ;
[ [ (deref-aliases) ] bi-curry@ bi ] with2 assoc-map! ;
: merge-values ( seq -- assoc )
reverse unclip [ assoc-union ] reduce ;
GENERIC: merge-value ( assoc value -- assoc' )
M: sequence merge-value merge-values merge-value ;
M: assoc merge-value over assoc-diff assoc-union! ;
GENERIC: apply-merge-keys ( already-applied-set obj -- obj' )
: ?apply-merge-keys ( set obj -- obj' )
2dup swap in? [ nip ] [ 2dup swap adjoin apply-merge-keys ] if ;
M: sequence apply-merge-keys
[ ?apply-merge-keys ] with map! ;
M: object apply-merge-keys nip ;
M: byte-array apply-merge-keys nip ;
M: string apply-merge-keys nip ;
: pop-at* ( key assoc -- value/f ? )
[ at* ] 2keep pick [ delete-at ] [ 2drop ] if ;
: ?apply-merge-key ( assoc -- assoc' )
T{ yaml-merge } over pop-at*
[ merge-value ] [ drop ] if ;
M: assoc apply-merge-keys
[ [ ?apply-merge-keys ] bi-curry@ bi ] with2 assoc-map!
?apply-merge-key ;
:: parse-yaml-doc ( parser event -- obj )
H{ } clone anchors [
parser event next-value
anchors get swap (deref-aliases)
IHS{ } clone swap ?apply-merge-keys
] with-variable ;
:: ?parse-yaml-doc ( parser event -- obj/f ? )
@ -345,18 +376,27 @@ GENERIC: emit-value ( emitter event anchor obj -- )
: emit-object ( emitter event obj -- ) [ f ] dip emit-value ;
: scalar-implicit-tag? ( tag str -- plain_implicit quoted_implicit )
: scalar-implicit-tag? ( tag str mapping-key? -- plain_implicit quoted_implicit )
implicit-tags get [
resolve-plain-scalar = t
] [ 2drop f f ] if ;
] [ 3drop f f ] if ;
:: emit-scalar ( emitter event anchor obj -- )
:: (emit-scalar) ( emitter event anchor obj mapping-key? -- )
event anchor
obj [ yaml-tag ] [ represent-scalar ] bi
-1 2over scalar-implicit-tag? YAML_ANY_SCALAR_STYLE
-1 2over mapping-key? scalar-implicit-tag? YAML_ANY_SCALAR_STYLE
yaml_scalar_event_initialize yaml-initialize-assert-ok
emitter event yaml_emitter_emit_asserted ;
: emit-mapping-key-scalar ( emitter event anchor obj -- ) t (emit-scalar) ;
: emit-scalar ( emitter event anchor obj -- ) f (emit-scalar) ;
! strings and special keys are the only things that need special treatment
! because they can have the same representation
: emit-mapping-key ( emitter event obj -- )
dup [ string? ] [ yaml-merge? ] bi or
[ [ f ] dip emit-mapping-key-scalar ] [ emit-object ] if ;
M: object emit-value ( emitter event anchor obj -- ) emit-scalar ;
M: yaml-anchor emit-value ( emitter event unused obj -- )
@ -379,7 +419,10 @@ M:: yaml-alias emit-value ( emitter event unused obj -- )
[ emit-object ] with with each ;
: emit-assoc-body ( emitter event assoc -- )
>alist concat emit-sequence-body ;
[
[ emit-mapping-key ]
[ emit-object ] bi-curry* 2bi
] with2 with2 assoc-each ;
: emit-linked-assoc-body ( emitter event linked-assoc -- )
>alist [ first2 swap associate ] map emit-sequence-body ;