From 18c88d99051d4226d3ddec4f3d2a30bfd4f5bf96 Mon Sep 17 00:00:00 2001 From: Jon Harper Date: Sat, 1 Mar 2014 15:42:43 +0100 Subject: [PATCH] YAML: convert some factor types to/from yaml types --- extra/yaml/conversion/authors.txt | 1 + extra/yaml/conversion/conversion-tests.factor | 17 ++++ extra/yaml/conversion/conversion.factor | 97 +++++++++++++++++++ extra/yaml/yaml.factor | 22 +++-- 4 files changed, 131 insertions(+), 6 deletions(-) create mode 100644 extra/yaml/conversion/authors.txt create mode 100644 extra/yaml/conversion/conversion-tests.factor create mode 100644 extra/yaml/conversion/conversion.factor diff --git a/extra/yaml/conversion/authors.txt b/extra/yaml/conversion/authors.txt new file mode 100644 index 0000000000..2c5e05bdac --- /dev/null +++ b/extra/yaml/conversion/authors.txt @@ -0,0 +1 @@ +Jon Harper diff --git a/extra/yaml/conversion/conversion-tests.factor b/extra/yaml/conversion/conversion-tests.factor new file mode 100644 index 0000000000..9d6ec0a442 --- /dev/null +++ b/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 diff --git a/extra/yaml/conversion/conversion.factor b/extra/yaml/conversion/conversion.factor new file mode 100644 index 0000000000..32a7af892a --- /dev/null +++ b/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 ; diff --git a/extra/yaml/yaml.factor b/extra/yaml/yaml.factor index 81becab7a5..51d72b6e9d 100644 --- a/extra/yaml/yaml.factor +++ b/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 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 ;