extra/yaml/conversion/conversion.factor

   1 ! Copyright (C) 2014 Jon Harper.
   2 ! See https://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 calendar.parser ;
   7 IN: yaml.conversion
   8
   9 ! https://yaml.org/type/
  10 CONSTANT: YAML_MERGE_TAG "tag:yaml.org,2002:merge"
  11 CONSTANT: YAML_VALUE_TAG "tag:yaml.org,2002:value"
  12
  13 ! !!!!!!!!!!!!!!
  14 ! tag resolution
  15 ! https://www.yaml.org/spec/1.2/spec.html
  16 ! 10.3. Core Schema
  17
  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])?))?/
  28
  29 : resolve-normal-plain-scalar ( str -- tag )
  30     {
  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 ] }
  41         [ drop YAML_STR_TAG ]
  42     } cond-case ;
  43
  44 CONSTANT: re-merge R/ <</
  45 CONSTANT: re-value R/ =/
  46 : (resolve-mapping-key-plain-scalar) ( str -- tag )
  47     {
  48         { [ re-merge matches? ] [ YAML_MERGE_TAG ] }
  49         { [ re-value matches? ] [ YAML_VALUE_TAG ] }
  50         [ drop YAML_STR_TAG ]
  51     } cond-case ;
  52
  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)
  56   ] [ nip ] if ;
  57
  58 : resolve-plain-scalar ( str mapping-key? -- tag )
  59     [ resolve-mapping-key-plain-scalar ] [ resolve-normal-plain-scalar ] if ;
  60
  61 CONSTANT: NON-SPECIFIC-TAG "!"
  62
  63 : resolve-explicit-tag ( tag default-tag -- tag )
  64     [ drop NON-SPECIFIC-TAG = not ] 2keep ? ;
  65
  66 : resolve-explicit-scalar-tag ( tag -- tag )
  67     YAML_DEFAULT_SCALAR_TAG resolve-explicit-tag ;
  68
  69 : resolve-explicit-sequence-tag ( tag -- tag )
  70     YAML_DEFAULT_SEQUENCE_TAG resolve-explicit-tag ;
  71
  72 : resolve-explicit-mapping-tag ( tag -- tag )
  73     YAML_DEFAULT_MAPPING_TAG resolve-explicit-tag ;
  74
  75 : resolve-scalar ( scalar-event mapping-key? -- tag )
  76     {
  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 ]
  80     } cond ;
  81
  82 ! !!!!!!!!!!!!!!
  83 ! yaml -> factor
  84
  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"
  89
  90 : construct-bool ( str -- ? ) R/ true|True|TRUE/ matches? ;
  91
  92 : construct-int ( str -- n ) string>number ;
  93
  94 : construct-infinity ( str -- -inf/+inf )
  95     first CHAR: - = -1/0. 1/0. ? ;
  96
  97 : construct-float ( str -- x )
  98     {
  99         { [ dup re-infinity matches? ] [ construct-infinity ] }
 100         { [ dup re-nan matches? ] [ drop 1/0. ] }
 101         [ string>number ]
 102     } cond ;
 103
 104 ! YAML allows
 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 ;
 115
 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 ;
 119
 120 TUPLE: yaml-merge ;
 121 C: <yaml-merge> yaml-merge
 122 TUPLE: yaml-value ;
 123 C: <yaml-value> yaml-value
 124
 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> ] }
 135         { YAML_STR_TAG [ ] }
 136     } case ;
 137
 138 : construct-pairs ( obj -- obj' )
 139     [ >alist first ] map ;
 140
 141 : construct-omap ( obj -- obj' )
 142     <linked-hash> [ assoc-union! ] reduce ;
 143
 144 : construct-sequence ( obj prev-event -- obj' )
 145     tag>> {
 146         { YAML_OMAP_TAG [ construct-omap ] }
 147         { YAML_PAIRS_TAG [ construct-pairs ] }
 148         [ drop ]
 149     } case ;
 150
 151 : construct-set ( obj -- obj' )
 152     keys >hash-set ;
 153
 154 : construct-mapping ( obj prev-event -- obj' )
 155     tag>> {
 156         { YAML_SET_TAG [ construct-set ] }
 157         [ drop ]
 158     } case ;
 159
 160 ! !!!!!!!!!!!!!!
 161 ! factor -> yaml
 162 GENERIC: represent-scalar ( obj -- str )
 163 GENERIC: yaml-tag ( obj -- tag )
 164
 165 M: string represent-scalar ( obj -- str ) ;
 166 M: string yaml-tag ( obj -- tag ) drop YAML_STR_TAG ;
 167
 168 M: boolean represent-scalar ( obj -- str ) "true" "false" ? ;
 169 M: boolean yaml-tag ( obj -- tag ) drop YAML_BOOL_TAG ;
 170
 171 M: integer represent-scalar ( obj -- str ) number>string ;
 172 M: integer yaml-tag ( obj -- tag ) drop YAML_INT_TAG ;
 173
 174 M: float represent-scalar ( obj -- str ) number>string ;
 175 M: float yaml-tag ( obj -- tag ) drop YAML_FLOAT_TAG ;
 176
 177 M: byte-array represent-scalar ( obj -- str ) >base64 "" like ;
 178 M: byte-array yaml-tag ( obj -- tag ) drop YAML_BINARY_TAG ;
 179
 180 M: timestamp represent-scalar ( obj -- str ) timestamp>rfc3339 ;
 181 M: timestamp yaml-tag ( obj -- str ) drop YAML_TIMESTAMP_TAG ;
 182
 183 M: yaml-merge represent-scalar ( obj -- str ) drop "<<" ;
 184 M: yaml-merge yaml-tag ( obj -- str ) drop YAML_MERGE_TAG ;
 185
 186 M: yaml-value represent-scalar ( obj -- str ) drop "=" ;
 187 M: yaml-value yaml-tag ( obj -- str ) drop YAML_VALUE_TAG ;