1 ! Copyright (C) 2014 Jon Harper.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs base64 byte-arrays combinators
4 combinators.extras hash-sets kernel linked-assocs math
5 math.parser regexp sequences strings yaml.ffi
6 calendar calendar.format ;
9 ! http://yaml.org/type/
10 CONSTANT: YAML_MERGE_TAG "tag:yaml.org,2002:merge"
11 CONSTANT: YAML_VALUE_TAG "tag:yaml.org,2002:value"
15 ! http://www.yaml.org/spec/1.2/spec.html
18 CONSTANT: re-null R" null|Null|NULL|~"
19 CONSTANT: re-empty R" "
20 CONSTANT: re-bool R" true|True|TRUE|false|False|FALSE"
21 CONSTANT: re-int10 R" [-+]?[0-9]+"
22 CONSTANT: re-int8 R" 0o[0-7]+"
23 CONSTANT: re-int16 R" 0x[0-9a-fA-F]+"
24 CONSTANT: re-number R" [-+]?(\.[0-9]+|[0-9]+(\.[0-9]*)?)([eE][-+]?[0-9]+)?"
25 CONSTANT: re-infinity R" [-+]?\.(inf|Inf|INF)"
26 CONSTANT: re-nan R" \.(nan|NaN|NAN)"
27 CONSTANT: re-timestamp R" [0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]|[0-9][0-9][0-9][0-9]-[0-9][0-9]?-[0-9][0-9]?([Tt]|[ \t]+)[0-9][0-9]?:[0-9][0-9]:[0-9][0-9](\.[0-9]*)?([ \t]*(Z|[-+][0-9][0-9]?(:[0-9][0-9])?))?"
29 : resolve-normal-plain-scalar ( str -- tag )
31 { [ re-null matches? ] [ YAML_NULL_TAG ] }
32 { [ re-empty matches? ] [ YAML_NULL_TAG ] }
33 { [ re-bool matches? ] [ YAML_BOOL_TAG ] }
34 { [ re-int10 matches? ] [ YAML_INT_TAG ] }
35 { [ re-int8 matches? ] [ YAML_INT_TAG ] }
36 { [ re-int16 matches? ] [ YAML_INT_TAG ] }
37 { [ re-number matches? ] [ YAML_FLOAT_TAG ] }
38 { [ re-infinity matches? ] [ YAML_FLOAT_TAG ] }
39 { [ re-nan matches? ] [ YAML_FLOAT_TAG ] }
40 { [ re-timestamp matches? ] [ YAML_TIMESTAMP_TAG ] }
44 CONSTANT: re-merge R" <<"
45 CONSTANT: re-value R" ="
46 : (resolve-mapping-key-plain-scalar) ( str -- tag )
48 { [ re-merge matches? ] [ YAML_MERGE_TAG ] }
49 { [ re-value matches? ] [ YAML_VALUE_TAG ] }
53 : resolve-mapping-key-plain-scalar ( str -- tag )
54 dup resolve-normal-plain-scalar dup YAML_STR_TAG = [
55 drop (resolve-mapping-key-plain-scalar)
58 : resolve-plain-scalar ( str mapping-key? -- tag )
59 [ resolve-mapping-key-plain-scalar ] [ resolve-normal-plain-scalar ] if ;
61 CONSTANT: NON-SPECIFIC-TAG "!"
63 : resolve-explicit-tag ( tag default-tag -- tag )
64 [ drop NON-SPECIFIC-TAG = not ] 2keep ? ;
66 : resolve-explicit-scalar-tag ( tag -- tag )
67 YAML_DEFAULT_SCALAR_TAG resolve-explicit-tag ;
69 : resolve-explicit-sequence-tag ( tag -- tag )
70 YAML_DEFAULT_SEQUENCE_TAG resolve-explicit-tag ;
72 : resolve-explicit-mapping-tag ( tag -- tag )
73 YAML_DEFAULT_MAPPING_TAG resolve-explicit-tag ;
75 : resolve-scalar ( scalar-event mapping-key? -- tag )
77 { [ over tag>> ] [ drop tag>> resolve-explicit-scalar-tag ] }
78 { [ over style>> YAML_PLAIN_SCALAR_STYLE = not ] [ 2drop YAML_STR_TAG ] }
79 [ [ value>> ] dip resolve-plain-scalar ]
85 CONSTANT: YAML_BINARY_TAG "tag:yaml.org,2002:binary"
86 CONSTANT: YAML_OMAP_TAG "tag:yaml.org,2002:omap"
87 CONSTANT: YAML_PAIRS_TAG "tag:yaml.org,2002:pairs"
88 CONSTANT: YAML_SET_TAG "tag:yaml.org,2002:set"
90 : construct-bool ( str -- ? ) R" true|True|TRUE" matches? ;
92 : construct-int ( str -- n ) string>number ;
94 : construct-infinity ( str -- -inf/+inf )
95 first CHAR: - = -1/0. 1/0. ? ;
97 : construct-float ( str -- x )
99 { [ dup re-infinity matches? ] [ construct-infinity ] }
100 { [ dup re-nan matches? ] [ drop 1/0. ] }
105 ! - multiple whitespaces between date and time
106 ! - multiple whitespaces between time and offset
107 ! - months, days and hours on 1 digit
108 ! preprocess to fix this mess...
109 : yaml>rfc3339 ( str -- str' )
110 R" -[0-9][^0-9]" [ [ CHAR: 0 1 ] dip insert-nth ] re-replace-with
111 R" -[0-9][^0-9]" [ [ CHAR: 0 1 ] dip insert-nth ] re-replace-with
112 R" [^0-9][0-9]:" [ [ CHAR: 0 1 ] dip insert-nth ] re-replace-with
113 R" [ \t]+" " " re-replace
114 CHAR: : over index cut CHAR: space swap remove append ;
116 : construct-timestamp ( obj -- obj' )
117 dup R" [0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]" matches?
118 [ ymd>timestamp ] [ yaml>rfc3339 rfc3339>timestamp ] if ;
121 C: <yaml-merge> yaml-merge
123 C: <yaml-value> yaml-value
125 : construct-scalar ( scalar-event mapping-key? -- scalar )
126 [ drop value>> ] [ resolve-scalar ] 2bi {
127 { YAML_NULL_TAG [ drop f ] }
128 { YAML_BOOL_TAG [ construct-bool ] }
129 { YAML_INT_TAG [ construct-int ] }
130 { YAML_FLOAT_TAG [ construct-float ] }
131 { YAML_BINARY_TAG [ base64> ] }
132 { YAML_TIMESTAMP_TAG [ construct-timestamp ] }
133 { YAML_MERGE_TAG [ drop <yaml-merge> ] }
134 { YAML_VALUE_TAG [ drop <yaml-value> ] }
138 : construct-pairs ( obj -- obj' )
139 [ >alist first ] map ;
141 : construct-omap ( obj -- obj' )
142 <linked-hash> [ assoc-union! ] reduce ;
144 : construct-sequence ( obj prev-event -- obj' )
146 { YAML_OMAP_TAG [ construct-omap ] }
147 { YAML_PAIRS_TAG [ construct-pairs ] }
151 : construct-set ( obj -- obj' )
154 : construct-mapping ( obj prev-event -- obj' )
156 { YAML_SET_TAG [ construct-set ] }
162 GENERIC: represent-scalar ( obj -- str )
163 GENERIC: yaml-tag ( obj -- tag )
165 M: string represent-scalar ( obj -- str ) ;
166 M: string yaml-tag ( obj -- tag ) drop YAML_STR_TAG ;
168 M: boolean represent-scalar ( obj -- str ) "true" "false" ? ;
169 M: boolean yaml-tag ( obj -- tag ) drop YAML_BOOL_TAG ;
171 M: integer represent-scalar ( obj -- str ) number>string ;
172 M: integer yaml-tag ( obj -- tag ) drop YAML_INT_TAG ;
174 M: float represent-scalar ( obj -- str ) number>string ;
175 M: float yaml-tag ( obj -- tag ) drop YAML_FLOAT_TAG ;
177 M: byte-array represent-scalar ( obj -- str ) >base64 "" like ;
178 M: byte-array yaml-tag ( obj -- tag ) drop YAML_BINARY_TAG ;
180 M: timestamp represent-scalar ( obj -- str ) timestamp>rfc3339 ;
181 M: timestamp yaml-tag ( obj -- str ) drop YAML_TIMESTAMP_TAG ;
183 M: yaml-merge represent-scalar ( obj -- str ) drop "<<" ;
184 M: yaml-merge yaml-tag ( obj -- str ) drop YAML_MERGE_TAG ;
186 M: yaml-value represent-scalar ( obj -- str ) drop "=" ;
187 M: yaml-value yaml-tag ( obj -- str ) drop YAML_VALUE_TAG ;