basis/toml/toml.factor

   1 ! Copyright (C) 2019 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays assocs hashtables kernel locals make
   5 math.parser peg peg.parsers regexp sequences splitting
   6 strings.parser ;
   7
   8 IN: toml
   9
  10 ERROR: duplicate-key key ;
  11
  12 ERROR: unknown-value value ;
  13
  14 <PRIVATE
  15
  16 ! FIXME: key = 1234abcd # should error!
  17
  18 TUPLE: table name array? entries ;
  19
  20 TUPLE: entry key value ;
  21
  22 : boolean-parser ( -- parser )
  23     "true" token [ drop t ] action
  24     "false" token [ drop f ] action
  25     2choice ;
  26
  27 : digits ( parser -- parser )
  28     "_" token [ drop f ] action 2choice repeat1 [ sift ] action ;
  29
  30 : sign ( -- parser )
  31     "+" token "-" token 2choice ;
  32
  33 : hexdigit ( -- parser )
  34     [
  35         CHAR: 0 CHAR: 9 range ,
  36         CHAR: a CHAR: f range ,
  37         CHAR: A CHAR: F range ,
  38     ] choice* ;
  39
  40 : hex ( -- parser )
  41     "0x" token hide hexdigit digits 2seq [ first hex> ] action ;
  42
  43 : decdigit ( -- parser )
  44     CHAR: 0 CHAR: 9 range ;
  45
  46 : dec ( -- parser )
  47     decdigit digits [ dec> ] action ;
  48
  49 : octdigit ( -- parser )
  50     CHAR: 0 CHAR: 7 range ;
  51
  52 : oct ( -- parser )
  53     "0o" token hide octdigit digits 2seq [ first oct> ] action ;
  54
  55 : bindigit ( -- parser )
  56     CHAR: 0 CHAR: 1 range ;
  57
  58 : bin ( -- parser )
  59     "0b" token hide bindigit digits 2seq [ first bin> ] action ;
  60
  61 : integer-parser ( -- parser )
  62     hex oct bin dec 4choice ;
  63
  64 : float ( -- parser )
  65     [
  66         sign optional ,
  67         decdigit digits optional ,
  68         "." token ,
  69         decdigit digits optional ,
  70         "e" token "E" token 2choice
  71         sign optional
  72         decdigit digits optional 3seq optional ,
  73     ] seq* [ unclip-last append "" concat-as string>number ] action ;
  74
  75 : +inf ( -- parser )
  76     "+" token optional "inf" token 2seq [ drop 1/0. ] action ;
  77
  78 : -inf ( -- parser )
  79     "-inf" token [ drop -1/0. ] action ;
  80
  81 : nan ( -- parser )
  82     sign optional "nan" token 2seq
  83     [ drop NAN: 8000000000000 ] action ;
  84
  85 : float-parser ( -- parser )
  86     float +inf -inf nan 4choice ;
  87
  88 : escaped ( -- parser )
  89     "\\" token hide [ "btnfr\"\\" member-eq? ] satisfy 2seq
  90     [ first escape ] action ;
  91
  92 : unicode ( -- parser )
  93     "\\u" token hide hexdigit 4 exactly-n 2seq
  94     "\\U" token hide hexdigit 8 exactly-n 2seq
  95     2choice [ first hex> ] action ;
  96
  97 : basic-string ( -- parser )
  98     escaped unicode [ "\"\n" member? not ] satisfy 3choice repeat0
  99     "\"" dup surrounded-by ;
 100
 101 : literal-string ( -- parser )
 102     [ "'\n" member? not ] satisfy repeat0
 103     "'" dup surrounded-by ;
 104
 105 : single-string ( -- parser )
 106     basic-string literal-string 2choice [ "" like ] action ;
 107
 108 : multi-basic-string ( -- parser )
 109     escaped unicode [ CHAR: \" = not ] satisfy 3choice repeat0
 110     "\"\"\"" dup surrounded-by ;
 111
 112 : multi-literal-string ( -- parser )
 113     [ CHAR: ' = not ] satisfy repeat0
 114     "'''" dup surrounded-by ;
 115
 116 : multi-string ( -- parser )
 117     multi-basic-string multi-literal-string 2choice [
 118         "" like "\n" ?head drop
 119         R/ \\[ \t\r\n]*\n[ \t\r\n]*/m "" re-replace
 120     ] action ;
 121
 122 : string-parser ( -- parser )
 123     multi-string single-string 2choice ;
 124
 125 : date-parser ( -- parser )
 126     [
 127         decdigit 4 exactly-n ,
 128         "-" token ,
 129         decdigit 2 exactly-n ,
 130         "-" token ,
 131         decdigit 2 exactly-n ,
 132     ] seq* [ "" concat-as ] action ;
 133
 134 : time-parser ( -- parser )
 135     [
 136         decdigit 2 exactly-n ,
 137         ":" token ,
 138         decdigit 2 exactly-n ,
 139         ":" token ,
 140         decdigit 2 exactly-n ,
 141         "." token decdigit repeat1 2seq optional ,
 142     ] seq* [ "" concat-as ] action ;
 143
 144 : timezone-parser ( -- parser )
 145     "Z" token
 146     "-" token
 147     decdigit 2 exactly-n ":" token
 148     decdigit 2 exactly-n 4seq [ "" concat-as ] action
 149     2choice ;
 150
 151 : datetime-parser ( -- parser )
 152     [
 153         date-parser ,
 154         "T" token " " token 2choice ,
 155         time-parser ,
 156         timezone-parser optional ,
 157     ] seq* [ "" concat-as ] action ;
 158
 159 : space ( -- parser )
 160     [ " \t" member? ] satisfy repeat0 ;
 161
 162 : whitespace ( -- parser )
 163     [ " \t\r\n" member? ] satisfy repeat0 ;
 164
 165 DEFER: value-parser
 166
 167 : array-parser ( -- parser )
 168     [
 169         "[" token hide ,
 170         whitespace hide ,
 171         value-parser
 172         whitespace "," token whitespace pack list-of ,
 173         whitespace hide ,
 174         "]" token hide ,
 175     ] seq* [ first { } like ] action ;
 176
 177 DEFER: key-value-parser
 178
 179 DEFER: update-toml
 180
 181 : inline-table-parser ( -- parser )
 182     [
 183         "{" token hide ,
 184         whitespace hide ,
 185         key-value-parser
 186         whitespace "," token whitespace pack list-of ,
 187         whitespace hide ,
 188         "}" token hide ,
 189     ] seq* [
 190         first [ length <hashtable> ] keep [ update-toml ] each
 191     ] action ;
 192
 193 : value-parser ( -- parser )
 194     [
 195         [
 196             boolean-parser ,
 197             datetime-parser ,
 198             date-parser ,
 199             time-parser ,
 200             float-parser ,
 201             integer-parser ,
 202             string-parser ,
 203             array-parser ,
 204             inline-table-parser ,
 205         ] choice*
 206     ] delay ;
 207
 208 : name-parser ( -- parser )
 209     [
 210         CHAR: A CHAR: Z range ,
 211         CHAR: a CHAR: z range ,
 212         CHAR: 0 CHAR: 9 range ,
 213         "_" token [ first ] action ,
 214         "-" token [ first ] action ,
 215     ] choice* repeat1 [ "" like ] action single-string 2choice ;
 216
 217 : comment-parser ( -- parser )
 218     [
 219         space hide ,
 220         "#" token ,
 221         [ CHAR: \n = not ] satisfy repeat0 ,
 222     ] seq* [ drop f ] action ;
 223
 224 : key-parser ( -- parser )
 225     name-parser "." token list-of [ { } like ] action ;
 226
 227 : key-value-parser ( -- parser )
 228     [
 229         space hide ,
 230         key-parser ,
 231         space hide ,
 232         "=" token hide ,
 233         space hide ,
 234         value-parser ,
 235         comment-parser optional hide ,
 236     ] seq* [ first2 entry boa ] action ;
 237
 238 : line-parser ( -- parser )
 239     "\n" token "\r\n" token 2choice ;
 240
 241 :: table-name-parser ( begin end -- parser )
 242     [
 243         begin token hide ,
 244         space hide ,
 245         name-parser
 246         space "." token space pack list-of
 247         [ { } like ] action ,
 248         space hide ,
 249         end token hide ,
 250         comment-parser optional hide ,
 251     ] seq* ;
 252
 253 : table-parser ( -- parser )
 254     [
 255         space hide ,
 256         "[[" "]]" table-name-parser [ t suffix! ] action
 257         "[" "]" table-name-parser [ f suffix! ] action
 258         2choice ,
 259         whitespace hide ,
 260         key-value-parser line-parser list-of optional ,
 261     ] seq* [ first2 [ first2 ] dip table boa ] action ;
 262
 263 : toml-parser ( -- parser )
 264     [
 265         whitespace hide ,
 266         [
 267             comment-parser ,
 268             table-parser ,
 269             key-value-parser ,
 270         ] choice* whitespace list-of ,
 271         whitespace hide ,
 272     ] seq* [ first sift { } like ] action ;
 273
 274 : check-no-key ( key assoc -- key assoc )
 275     2dup at* nip [ over duplicate-key ] when ;
 276
 277 : deep-at ( keys assoc -- value )
 278     swap [
 279         over ?at [ nip ] [
 280             H{ } clone [ swap rot check-no-key set-at ] keep
 281         ] if
 282     ] each ;
 283
 284 GENERIC: update-toml ( assoc entry -- assoc )
 285
 286 M: entry update-toml
 287     [ key>> unclip-last [ over deep-at ] dip ] [ value>> ] bi
 288     swap rot check-no-key set-at ;
 289
 290 M: table update-toml
 291     [ name>> unclip-last [ over deep-at ] dip ]
 292     [ entries>> [ H{ } clone ] dip [ update-toml ] each swap rot ]
 293     [ array?>> [ push-at ] [ check-no-key set-at ] if ] tri ;
 294
 295 PRIVATE>
 296
 297 : toml> ( string -- assoc )
 298     [ H{ } clone ] dip toml-parser parse [ update-toml ] each ;