--- /dev/null
+! 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
--- /dev/null
+! 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 ;
! 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
: 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 =
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 ;
: 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 ]
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 ;