YAML: support !!set, !!omap and !!pair

2014-03-25 18:51:37 +01:00 · 2014-03-25 18:51:37 +01:00 · 2db5962cc3
parent c7613e62a0
commit 2db5962cc3
3 changed files with 154 additions and 79 deletions
--- a/extra/yaml/conversion/conversion.factor
+++ b/extra/yaml/conversion/conversion.factor
@ -1,8 +1,8 @@
 ! Copyright (C) 2014 Jon Harper.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors base64 byte-arrays combinators
-combinators.extras kernel math math.parser regexp sequences
-strings yaml.ffi ;
+USING: accessors assocs base64 byte-arrays combinators
+combinators.extras hash-sets kernel linked-assocs math
+math.parser regexp sequences strings yaml.ffi ;
 IN: yaml.conversion

 ! !!!!!!!!!!!!!!
@ -76,6 +76,25 @@ CONSTANT:  YAML_BINARY_TAG "tag:yaml.org,2002:binary"
        { YAML_STR_TAG   [ ] }
    } case ;

+CONSTANT: YAML_OMAP_TAG  "tag:yaml.org,2002:omap"
+CONSTANT: YAML_PAIRS_TAG "tag:yaml.org,2002:pairs"
+: construct-pairs ( obj -- obj' ) [ >alist first ] map ;
+: construct-omap ( obj -- obj' ) <linked-hash> [ assoc-union! ] reduce ;
+: construct-sequence ( obj prev-event -- obj' )
+    tag>> {
+        { YAML_OMAP_TAG [ construct-omap ] }
+        { YAML_PAIRS_TAG [ construct-pairs ] }
+        [ drop ]
+    } case ;
+
+CONSTANT: YAML_SET_TAG   "tag:yaml.org,2002:set"
+: construct-set ( obj -- obj' ) keys >hash-set ;
+: construct-mapping ( obj prev-event -- obj' )
+    tag>> {
+        { YAML_SET_TAG [ construct-set ] }
+        [ drop ]
+    } case ;
+
 ! !!!!!!!!!!!!!!
 ! factor -> yaml
 GENERIC: represent-scalar ( obj -- str )
--- a/extra/yaml/yaml-tests.factor
+++ b/extra/yaml/yaml-tests.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2014 Jon Harper.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: literals tools.test yaml ;
+USING: assocs linked-assocs literals tools.test yaml ;
 IN: yaml.tests

 ! TODO real conformance tests here
@ -225,34 +225,33 @@ ${ construct-seq-obj } [ $ construct-seq-obj >yaml yaml> ] unit-test

 ! !!!!!!!!!!!!!!!
 ! construct-set
-! TODO implement this to hash-set
-! CONSTANT: construct-set-obj H{
-!   {
-!    "baseball players" HS{
-!       "Mark McGwire"
-!       "Sammy Sosa"
-!       "Ken Griffey"
-!     }
-!   } {
-!     "baseball teams" HS{
-!       "Boston Red Sox"
-!       "Detroit Tigers"
-!       "New York Yankees"
-!     }
-!   }
-! }
-! 
-! CONSTANT: construct-set-str """# Explicitly typed set.
-! baseball players: !!set
-!   ? Mark McGwire
-!   ? Sammy Sosa
-!   ? Ken Griffey
-! # Flow style
-! baseball teams: !!set { Boston Red Sox, Detroit Tigers, New York Yankees }
-! """
-! 
-! ${ construct-set-obj } [ $ construct-set-str yaml> ] unit-test
-! ${ construct-set-obj } [ $ construct-set-obj >yaml yaml> ] unit-test
+CONSTANT: construct-set-obj H{
+  {
+   "baseball players" HS{
+      "Mark McGwire"
+      "Sammy Sosa"
+      "Ken Griffey"
+    }
+  } {
+    "baseball teams" HS{
+      "Boston Red Sox"
+      "Detroit Tigers"
+      "New York Yankees"
+    }
+  }
+}
+
+CONSTANT: construct-set-str """# Explicitly typed set.
+baseball players: !!set
+  ? Mark McGwire
+  ? Sammy Sosa
+  ? Ken Griffey
+# Flow style
+baseball teams: !!set { Boston Red Sox, Detroit Tigers, New York Yankees }
+"""
+
+${ construct-set-obj } [ $ construct-set-str yaml> ] unit-test
+${ construct-set-obj } [ $ construct-set-obj >yaml yaml> ] unit-test

 ! !!!!!!!!!!!!!!!
 ! construct-binary
@ -370,38 +369,80 @@ ${ construct-binary-obj } [ $ construct-binary-obj >yaml yaml> ] unit-test

 ! !!!!!!!!!!!!!!!
 ! construct-omap
-! TODO what to do with omap ?
-! CONSTANT: construct-omap-obj f
-! 
-! CONSTANT: construct-omap-str """# Explicitly typed ordered map (dictionary).
-! Bestiary: !!omap
-!   - aardvark: African pig-like ant eater. Ugly.
-!   - anteater: South-American ant eater. Two species.
-!   - anaconda: South-American constrictor snake. Scaly.
-!   # Etc.
-! # Flow style
-! Numbers: !!omap [ one: 1, two: 2, three : 3 ]
-! """
-! 
-! ${ construct-omap-obj } [ $ construct-omap-str yaml> ] unit-test
-! ${ construct-omap-obj } [ $ construct-omap-obj >yaml yaml> ] unit-test
+CONSTANT: construct-omap-obj H{
+  {
+    "Bestiary"
+    $[ <linked-hash> {
+        { "aardvark" "African pig-like ant eater. Ugly." }
+        { "anteater" "South-American ant eater. Two species." }
+        { "anaconda" "South-American constrictor snake. Scaly." }
+    } assoc-union! ]
+  } {
+    "Numbers"
+    $[ <linked-hash> {
+        { "one" 1 }
+        { "two" 2 }
+        { "three" 3 }
+    } assoc-union! ]
+  }
+}
+
+CONSTANT: construct-omap-str """# Explicitly typed ordered map (dictionary).
+Bestiary: !!omap
+  - aardvark: African pig-like ant eater. Ugly.
+  - anteater: South-American ant eater. Two species.
+  - anaconda: South-American constrictor snake. Scaly.
+  # Etc.
+# Flow style
+Numbers: !!omap [ one: 1, two: 2, three : 3 ]
+"""
+
+${ construct-omap-obj } [ $ construct-omap-str yaml> ] unit-test
+${ construct-omap-obj } [ $ construct-omap-obj >yaml yaml> ] unit-test

 ! !!!!!!!!!!!!!!!
 ! construct-pairs
-! TODO what to do with pairs ?
-! CONSTANT: construct-pairs-obj f
-! 
-! CONSTANT: construct-pairs-str """# Explicitly typed pairs.
-! Block tasks: !!pairs
-!   - meeting: with team.
-!   - meeting: with boss.
-!   - break: lunch.
-!   - meeting: with client.
-! Flow tasks: !!pairs [ meeting: with team, meeting: with boss ]
-! """
-! 
-! ${ construct-pairs-obj } [ $ construct-pairs-str yaml> ] unit-test
-! ${ construct-pairs-obj } [ $ construct-pairs-obj >yaml yaml> ] unit-test
+CONSTANT: construct-pairs-obj H{
+  {
+    "Block tasks" {
+      { "meeting" "with team." }
+      { "meeting" "with boss." }
+      { "break" "lunch." }
+      { "meeting" "with client." }
+    }
+  } {
+    "Flow tasks" {
+      { "meeting" "with team" } { "meeting" "with boss" }
+    }
+  }
+}
+
+CONSTANT: construct-pairs-str """# Explicitly typed pairs.
+Block tasks: !!pairs
+  - meeting: with team.
+  - meeting: with boss.
+  - break: lunch.
+  - meeting: with client.
+Flow tasks: !!pairs [ meeting: with team, meeting: with boss ]
+"""
+
+CONSTANT: construct-pairs-obj-roundtripped H{
+  {
+    "Block tasks" {
+      H{ { "meeting" "with team." } }
+      H{ { "meeting" "with boss." } }
+      H{ { "break" "lunch." } }
+      H{ { "meeting" "with client." } }
+    }
+  } {
+    "Flow tasks" {
+      H{ { "meeting" "with team" } } H{ { "meeting" "with boss" } }
+    }
+  }
+}
+
+${ construct-pairs-obj } [ $ construct-pairs-str yaml> ] unit-test
+${ construct-pairs-obj } [ $ construct-pairs-obj >yaml yaml> ] unit-test

 ! !!!!!!!!!!!!!!!
 ! construct-timestamp
--- 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.data assocs byte-arrays classes.struct
-combinators destructors io.encodings.string io.encodings.utf8
-kernel libc locals make namespaces sequences strings yaml.ffi
-yaml.conversion ;
+USING: accessors alien.data arrays assocs byte-arrays
+classes.struct combinators destructors hashtables
+io.encodings.string io.encodings.utf8 kernel libc linked-assocs
+locals make namespaces sequences sets strings yaml.conversion
+yaml.ffi ;
+FROM: sets => set ;
 IN: yaml

 <PRIVATE
@ -56,13 +58,15 @@ TUPLE: factor_yaml_event_t type data start_mark end_mark ;
 DEFER: parse-sequence
 DEFER: parse-mapping
 : (parse-sequence) ( parser event prev-event -- obj )
-    [ parse-sequence ] [ sequence_start>> ?register-anchor ] bi* ;
+    data>> sequence_start>>
+    [ [ parse-sequence ] [ construct-sequence ] bi* ] [ 2nip ?register-anchor ] 3bi ;
 : (parse-mapping) ( parser event prev-event -- obj )
-    [ parse-mapping ] [ mapping_start>> ?register-anchor ] bi* ;
+    data>> mapping_start>>
+    [ [ parse-mapping ] [ construct-mapping ] bi* ] [ 2nip ?register-anchor ] 3bi ;
 : next-complex-value ( parser event prev-event -- obj )
    dup type>> {
-        { YAML_SEQUENCE_START_EVENT [ data>> (parse-sequence) ] }
-        { YAML_MAPPING_START_EVENT [ data>> (parse-mapping) ] }
+        { YAML_SEQUENCE_START_EVENT [ (parse-sequence) ] }
+        { YAML_MAPPING_START_EVENT [ (parse-mapping) ] }
        { YAML_ALIAS_EVENT [ 2nip deref-anchor ] }
        [ throw ]
    } case ;
@ -90,7 +94,7 @@ DEFER: parse-mapping
        ] until
    ] H{ } make ;

-:: parse-sequence ( parser event -- seq )
+:: parse-sequence ( parser event  -- seq )
    [
        f :> done!
        [ done ] [
@ -185,8 +189,8 @@ GENERIC: emit-value ( emitter event obj -- )

 M: object emit-value ( emitter event obj -- ) emit-scalar ;

-:: emit-sequence-start ( emitter event -- )
-    event f YAML_SEQ_TAG f YAML_ANY_SEQUENCE_STYLE
+:: emit-sequence-start ( emitter event tag -- )
+    event f tag f YAML_ANY_SEQUENCE_STYLE
    yaml_sequence_start_event_initialize yaml-assert-ok
    emitter event yaml_emitter_emit yaml-assert-ok ;

@ -196,16 +200,26 @@ M: object emit-value ( emitter event obj -- ) emit-scalar ;

 : emit-sequence ( emitter event seq -- )
    [ emit-value ] with with each ;
+: emit-assoc ( emitter event assoc -- )
+    >alist concat emit-sequence ;
+: emit-linked-assoc ( emitter event linked-assoc -- )
+    >alist [ first2 swap associate ] map emit-sequence ;
+: emit-set ( emitter event set -- )
+    [ members ] [ cardinality f <array> ] bi zip concat emit-sequence ;

 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 ]
+    [ drop YAML_SEQ_TAG emit-sequence-start ]
    [ emit-sequence ]
    [ drop emit-sequence-end ] 3tri ;
+M: linked-assoc emit-value ( emitter event assoc -- )
+    [ drop YAML_OMAP_TAG emit-sequence-start ]
+    [ emit-linked-assoc ]
+    [ drop emit-sequence-end ] 3tri ;

-:: emit-assoc-start ( emitter event -- )
-    event f YAML_MAP_TAG f YAML_ANY_MAPPING_STYLE
+:: emit-assoc-start ( emitter event tag -- )
+    event f tag f YAML_ANY_MAPPING_STYLE
    yaml_mapping_start_event_initialize yaml-assert-ok
    emitter event yaml_emitter_emit yaml-assert-ok ;

@ -213,13 +227,14 @@ M: sequence emit-value ( emitter event seq -- )
    dup yaml_mapping_end_event_initialize yaml-assert-ok
    yaml_emitter_emit yaml-assert-ok ;

-: emit-assoc ( emitter event assoc -- )
-    [ [ emit-value ] with with bi@ ] with with assoc-each ;
-
 M: assoc emit-value ( emitter event seq -- )
-    [ drop emit-assoc-start ]
+    [ drop YAML_MAP_TAG emit-assoc-start ]
    [ emit-assoc ]
    [ drop emit-assoc-end ] 3tri ;
+M: set emit-value ( emitter event set -- )
+    [ drop YAML_SET_TAG emit-assoc-start ]
+    [ emit-set ]
+    [ drop emit-assoc-end ] 3tri ;

 ! registers destructors (use with with-destructors)
 :: init-emitter ( -- emitter event )