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
"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
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
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 ] }
[ 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 )
: 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 ;
! !!!!!!!!!!!!!!
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 ;
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 ;
! 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
! !!!!!!!!!!!!!!!
! 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
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
[ 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 ?!?
[ 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 )
YAML_MAPPING_END_EVENT = [
t done! f f
] [
- event ?scalar-value
+ event ?mapping-key-scalar-value
] if
] with-destructors
done [ 2drop ] [
[ 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 ;
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 ? )
: 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 -- )
[ 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 ;
projects / factor.git / commitdiff