YAML: support !!value in !!map

diff --git a/extra/yaml/conversion/conversion.factor b/extra/yaml/conversion/conversion.factor
index d14846ad28efe69131c63228e7fbe784cfa06451..daee389da74d0e15727abb833ea499713502664f 100644 (file)
--- a/extra/yaml/conversion/conversion.factor
+++ b/extra/yaml/conversion/conversion.factor
@@ -8,6 +8,7 @@ IN: yaml.conversion
 
 ! http://yaml.org/type/
 CONSTANT: YAML_MERGE_TAG "tag:yaml.org,2002:merge"
+CONSTANT: YAML_VALUE_TAG "tag:yaml.org,2002:value"
 
 ! !!!!!!!!!!!!!!
 ! tag resolution
@@ -41,9 +42,11 @@ CONSTANT: re-timestamp R/ [0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]|[0-9][0-9][
     } cond-case ;
 
 CONSTANT: re-merge R/ <</
+CONSTANT: re-value R/ =/
 : (resolve-mapping-key-plain-scalar) ( str -- tag )
     {
         { [ re-merge matches? ] [ YAML_MERGE_TAG ] }
+        { [ re-value matches? ] [ YAML_VALUE_TAG ] }
         [ drop YAML_STR_TAG ]
     } cond-case ;
 
@@ -116,6 +119,8 @@ CONSTANT: YAML_SET_TAG "tag:yaml.org,2002:set"
 
 TUPLE: yaml-merge ;
 C: <yaml-merge> yaml-merge
+TUPLE: yaml-value ;
+C: <yaml-value> yaml-value
 
 : construct-scalar ( scalar-event mapping-key? -- scalar )
     [ drop value>> ] [ resolve-scalar ] 2bi {
@@ -126,6 +131,7 @@ C: <yaml-merge> yaml-merge
         { YAML_BINARY_TAG [ base64> ] }
         { YAML_TIMESTAMP_TAG [ construct-timestamp ] }
         { YAML_MERGE_TAG [ drop <yaml-merge> ] }
+        { YAML_VALUE_TAG [ drop <yaml-value> ] }
         { YAML_STR_TAG [ ] }
     } case ;
 
@@ -176,3 +182,6 @@ 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 ;
+
+M: yaml-value represent-scalar ( obj -- str ) drop "=" ;
+M: yaml-value yaml-tag ( obj -- str ) drop YAML_VALUE_TAG ;

diff --git a/extra/yaml/yaml-tests.factor b/extra/yaml/yaml-tests.factor
index 7a8d5fea74c7108fa76b4625f7075b1c39b423f0..566ab49a37d31f9b08897625742c201ea7d5b0e8 100644 (file)
--- a/extra/yaml/yaml-tests.factor
+++ b/extra/yaml/yaml-tests.factor
@@ -679,9 +679,7 @@ ${ construct-timestamp-obj } [ $ construct-timestamp-obj >yaml yaml> ] unit-test
 
 ! !!!!!!!!!!!!!!!
 ! construct-value
-! TODO: find something better to do with '=' ? see http://yaml.org/type/value.html
-! Maybe a global parameter to replace all maps with their default values ? See pyyaml SafeConstructor
-CONSTANT: construct-value-obj {
+CONSTANT: construct-value-unsafe-obj {
     H{ { "link with" { "library1.dll" "library2.dll" } } }
     H{ {
         "link with" {
@@ -690,6 +688,10 @@ CONSTANT: construct-value-obj {
         }
     } }
 }
+CONSTANT: construct-value-safe-obj {
+    H{ { "link with" { "library1.dll" "library2.dll" } } }
+    H{ { "link with" { "library1.dll" "library2.dll" } } }
+}
 
 CONSTANT: construct-value-str """---     # Old schema
 link with:
@@ -703,8 +705,8 @@ link with:
     version: 2.3
 """
 
-${ construct-value-obj } [ $ construct-value-str yaml-docs> ] unit-test
-${ construct-value-obj } [ $ construct-value-obj >yaml-docs yaml-docs> ] unit-test
+${ construct-value-safe-obj } [ $ construct-value-str yaml-docs> ] unit-test
+${ construct-value-safe-obj } [ $ construct-value-safe-obj >yaml-docs yaml-docs> ] unit-test
 
 ! !!!!!!!!!!!!!!!
 ! errors

diff --git a/extra/yaml/yaml.factor b/extra/yaml/yaml.factor
index 8774023363387d1222c4fad5075d51e784c69d8b..f990cbd9c32f50cecf4bde9d9bbaa14859bbc27d 100644 (file)
--- a/extra/yaml/yaml.factor
+++ b/extra/yaml/yaml.factor
@@ -232,9 +232,11 @@ M: string apply-merge-keys nip ;
 : ?apply-merge-key ( assoc -- assoc' )
     T{ yaml-merge } over pop-at*
     [ merge-value ] [ drop ] if ;
+: ?apply-default-key ( assoc -- obj' )
+    T{ yaml-value } over pop-at* [ nip ] [ drop ] if ;
 M: assoc apply-merge-keys
     [ [ ?apply-merge-keys ] bi-curry@ bi ] with2 assoc-map!
-    ?apply-merge-key ;
+    ?apply-merge-key ?apply-default-key ;
 
 :: parse-yaml-doc ( parser event -- obj )
     H{ } clone anchors [
@@ -394,7 +396,7 @@ GENERIC: emit-value ( emitter event anchor obj -- )
 ! 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
+    dup { [ string? ] [ yaml-merge? ] [ yaml-value? ] } 1||
     [ [ f ] dip emit-mapping-key-scalar ] [ emit-object ] if ;
 
 M: object emit-value ( emitter event anchor obj -- ) emit-scalar ;