YAML: convert some factor types to/from yaml types

extra/yaml/conversion/authors.txt

@@ -0,0 +1 @@
+Jon Harper

extra/yaml/conversion/conversion-tests.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2014 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel literals sequences tools.test yaml.ffi yaml.conversion ;
+IN: yaml.conversion.tests
+
+: resolve-test ( res str -- ) [ resolve-plain-scalar ] curry unit-test ;
+: resolve-tests ( res seq -- ) [
+  [ resolve-plain-scalar ] curry unit-test
+] with each ;
+
+${ YAML_NULL_TAG } "null" resolve-test
+${ YAML_NULL_TAG } ""     resolve-test
+${ YAML_STR_TAG } "\"\""  resolve-test
+${ YAML_BOOL_TAG } { "true" "True" "false" "FALSE" } resolve-tests
+${ YAML_INT_TAG } { "0" "0o7" "0x3A" "-19" } resolve-tests
+${ YAML_FLOAT_TAG } { "0." "-0.0" ".5" "+12e03" "-2E+05" } resolve-tests
+${ YAML_FLOAT_TAG } { ".inf" "-.Inf" "+.INF" ".NAN" } resolve-tests

extra/yaml/conversion/conversion.factor

@@ -0,0 +1,97 @@
+! Copyright (C) 2014 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors base64 byte-arrays combinators
+combinators.extras kernel locals math math.parser regexp
+sequences strings yaml.ffi ;
+IN: yaml.conversion
+
+! !!!!!!!!!!!!!!
+! tag resolution
+! http://www.yaml.org/spec/1.2/spec.html
+! 10.3. Core Schema
+: resolve-null? ( str -- ? )     R/ null|Null|NULL|~/ matches? ;
+: resolve-empty? ( str -- ? )    R/ / matches? ;
+: resolve-bool? ( str -- ? )     R/ true|True|TRUE|false|False|FALSE/ matches? ;
+: resolve-int10? ( str -- ? )    R/ [-+]?[0-9]+/ matches? ;
+: resolve-int8? ( str -- ? )     R/ 0o[0-7]+/ matches? ;
+: resolve-int16? ( str -- ? )    R/ 0x[0-9a-fA-F]+/ matches? ;
+: resolve-number? ( str -- ? )   R/ [-+]?(\.[0-9]+|[0-9]+(\.[0-9]*)?)([eE][-+]?[0-9]+)?/ matches? ;
+: resolve-infinity? ( str -- ? ) R/ [-+]?(\.inf|\.Inf|\.INF)/ matches? ;
+: resolve-nan? ( str -- ? )      R/ \.nan|\.NaN|\.NAN/ matches? ;
+
+: resolve-plain-scalar ( str -- tag )
+    {
+        { [ resolve-null? ] [ YAML_NULL_TAG ] }
+        { [ resolve-empty? ] [ YAML_NULL_TAG ] }
+        { [ resolve-bool? ] [ YAML_BOOL_TAG ] }
+        { [ resolve-int10? ] [ YAML_INT_TAG ] }
+        { [ resolve-int8? ] [ YAML_INT_TAG ] }
+        { [ resolve-int16? ] [ YAML_INT_TAG ] }
+        { [ resolve-number? ] [ YAML_FLOAT_TAG ] }
+        { [ resolve-infinity? ] [ YAML_FLOAT_TAG ] }
+        { [ resolve-nan? ] [ YAML_FLOAT_TAG ] }
+        [ drop YAML_STR_TAG ]
+    } cond-case ;
+
+CONSTANT: NON-SPECIFIC-TAG "!"
+: resolve-explicit-tag ( tag default-tag -- tag )
+    [ drop NON-SPECIFIC-TAG = not ] 2keep ? ;
+: resolve-explicit-scalar-tag ( tag -- tag )
+    YAML_DEFAULT_SCALAR_TAG resolve-explicit-tag ;
+: resolve-explicit-sequence-tag ( tag -- tag )
+    YAML_DEFAULT_SEQUENCE_TAG resolve-explicit-tag ;
+: resolve-explicit-mapping-tag ( tag -- tag )
+    YAML_DEFAULT_MAPPING_TAG resolve-explicit-tag ;
+
+: resolve-scalar ( scalar-event -- tag )
+    {
+        { [ dup tag>> ] [ tag>> resolve-explicit-scalar-tag ] }
+        { [ dup style>> YAML_PLAIN_SCALAR_STYLE = not ] [ drop YAML_STR_TAG ] }
+        [ value>> resolve-plain-scalar ]
+    } cond ;
+
+! !!!!!!!!!!!!!!
+! yaml -> factor
+: construct-bool ( str -- ? )     R/ true|True|TRUE/ matches? ;
+: construct-int ( str -- n )     string>number ;
+: construct-infinity ( str -- -inf/+inf )
+    first CHAR: - =
+    [ -1/0. ] [ 1/0. ] if ;
+: construct-float ( str -- x )
+    {
+        { [ dup resolve-infinity? ] [ construct-infinity ] }
+        { [ dup resolve-nan? ] [ drop 1/0. ] }
+        [ string>number ]
+    } cond ;
+
+CONSTANT:  YAML_BINARY_TAG "tag:yaml.org,2002:binary"
+
+: construct-scalar ( scalar-event -- scalar )
+    [ value>> ] [ resolve-scalar ] bi {
+        { 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_STR_TAG   [ ] }
+    } case ;
+
+! !!!!!!!!!!!!!!
+! factor -> yaml
+GENERIC: represent-scalar ( obj -- str )
+GENERIC: yaml-tag ( obj -- tag )
+
+M: string represent-scalar ( obj -- str ) ;
+M: string yaml-tag ( obj -- tag ) drop YAML_STR_TAG ;
+
+M: boolean represent-scalar ( obj -- str ) "true" "false" ? ;
+M: boolean yaml-tag ( obj -- tag ) drop YAML_BOOL_TAG ;
+
+M: integer represent-scalar ( obj -- str ) number>string ;
+M: integer yaml-tag ( obj -- tag ) drop YAML_INT_TAG ;
+
+M: float represent-scalar ( obj -- str ) number>string ;
+M: float yaml-tag ( obj -- tag ) drop YAML_FLOAT_TAG ;
+
+M: byte-array represent-scalar ( obj -- str ) >base64 >string ;
+M: byte-array yaml-tag ( obj -- tag ) drop YAML_BINARY_TAG ;

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.c-types alien.data alien.syntax assocs
-classes.struct combinators continuations destructors
-io.encodings.string io.encodings.utf8 kernel libc locals make
-math namespaces prettyprint sequences strings yaml.ffi ;
+base64 byte-arrays classes.struct combinators continuations
+destructors io.encodings.string io.encodings.utf8 kernel libc
+locals make math math.parser namespaces prettyprint sequences
+strings yaml.ffi yaml.conversion ;
+FROM: math => float ;
 IN: yaml
 
 <PRIVATE
@@ -11,7 +13,7 @@ IN: yaml
 : yaml-assert-ok ( ? -- ) [ "yaml error" throw ] unless ;
 
 : event>scalar ( event -- obj )
-    data>> scalar>> value>> ;
+    data>> scalar>> construct-scalar ;
 
 : ?scalar-value ( event -- scalar/f f/type )
     dup type>> YAML_SCALAR_EVENT =
@@ -132,15 +134,20 @@ SYMBOL: yaml-write-buffer
 
 GENERIC: emit-value ( emitter event obj -- )
 
-M:: string emit-value ( emitter event string -- )
-    event f YAML_STR_TAG string -1 f f YAML_ANY_SCALAR_STYLE
+:: emit-scalar ( emitter event obj -- )
+    event f
+    obj [ yaml-tag ] [ represent-scalar ] bi
+    -1 f f YAML_ANY_SCALAR_STYLE
     yaml_scalar_event_initialize yaml-assert-ok
     emitter event yaml_emitter_emit yaml-assert-ok ;
 
+M: object emit-value ( emitter event obj -- ) emit-scalar ;
+
 :: emit-sequence-start ( emitter event -- )
     event f YAML_SEQ_TAG f YAML_ANY_SEQUENCE_STYLE
     yaml_sequence_start_event_initialize yaml-assert-ok
     emitter event yaml_emitter_emit yaml-assert-ok ;
+
 : emit-sequence-end ( emitter event -- )
     dup yaml_sequence_end_event_initialize yaml-assert-ok
     yaml_emitter_emit yaml-assert-ok ;
@@ -148,6 +155,8 @@ M:: string emit-value ( emitter event string -- )
 : emit-sequence ( emitter event seq -- )
     [ emit-value ] with with each ;
 
+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 ]
     [ emit-sequence ]
@@ -157,6 +166,7 @@ M: sequence emit-value ( emitter event seq -- )
     event f YAML_MAP_TAG f YAML_ANY_MAPPING_STYLE
     yaml_mapping_start_event_initialize yaml-assert-ok
     emitter event yaml_emitter_emit yaml-assert-ok ;
+
 : emit-assoc-end ( emitter event -- )
     dup yaml_mapping_end_event_initialize yaml-assert-ok
     yaml_emitter_emit yaml-assert-ok ;