basis/toml/toml.factor

   1 ! Copyright (C) 2019 John Benediktsson
   2 ! See https://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors ascii assocs calendar.parser hashtables
   5 io.encodings.utf8 io.files kernel make math.parser peg
   6 peg.parsers regexp sequences splitting strings.parser ;
   7
   8 ! https://github.com/toml-lang/toml/blob/main/toml.abnf
   9
  10 IN: toml
  11
  12 ERROR: duplicate-key key ;
  13
  14 ERROR: unknown-value value ;
  15
  16 <PRIVATE
  17
  18 TUPLE: table name array? ;
  19
  20 TUPLE: entry key value ;
  21
  22 : check-no-key ( key assoc -- key assoc )
  23     2dup at* nip [ over duplicate-key ] when ;
  24
  25 : entries-at ( table keys -- key entries )
  26     unclip-last -rot [
  27         over ?at [ nip ] [
  28             H{ } clone [ spin check-no-key set-at ] keep
  29         ] if
  30     ] each ;
  31
  32 GENERIC: update-toml ( root table entry -- root table' )
  33
  34 M: entry update-toml
  35     dupd [ key>> entries-at ] [ value>> ] bi
  36     -rot check-no-key set-at ;
  37
  38 M: table update-toml
  39     nip dupd [ name>> entries-at ] [ array?>> ] bi
  40     H{ } clone [
  41         swap [ -rot push-at ] [ -rot check-no-key set-at ] if
  42     ] keep ;
  43
  44 : ws ( -- parser )
  45     [ " \t" member? ] satisfy repeat0 ;
  46
  47 : newline ( -- parser )
  48     "\n" token "\r\n" token 2choice ;
  49
  50 : boolean-parser ( -- parser )
  51     "true" token [ drop t ] action
  52     "false" token [ drop f ] action
  53     2choice ;
  54
  55 : digits ( parser -- parser )
  56     "_" token [ drop f ] action 2choice repeat1 [ sift ] action ;
  57
  58 : sign ( -- parser )
  59     "+" token "-" token 2choice ;
  60
  61 : hexdigit ( -- parser )
  62     CHAR: 0 CHAR: 9 range
  63     CHAR: a CHAR: f range
  64     CHAR: A CHAR: F range 3choice ;
  65
  66 : hex-parser ( -- parser )
  67     sign optional "0x" token hexdigit digits 3seq
  68     [ "" concat-as string>number ] action ;
  69
  70 : decdigit ( -- parser )
  71     CHAR: 0 CHAR: 9 range ;
  72
  73 : dec-parser ( -- parser )
  74     sign optional decdigit digits 2seq
  75     [ "" concat-as string>number ] action ;
  76
  77 : octdigit ( -- parser )
  78     CHAR: 0 CHAR: 7 range ;
  79
  80 : oct-parser ( -- parser )
  81     sign optional "0o" token octdigit digits 3seq
  82     [ "" concat-as string>number ] action ;
  83
  84 : bindigit ( -- parser )
  85     CHAR: 0 CHAR: 1 range ;
  86
  87 : bin-parser ( -- parser )
  88     sign optional "0b" token bindigit digits 3seq
  89     [ "" concat-as string>number ] action ;
  90
  91 : integer-parser ( -- parser )
  92     hex-parser oct-parser bin-parser dec-parser 4choice ;
  93
  94 : exponent ( -- parser )
  95     "e" token "E" token 2choice sign optional
  96     decdigit digits optional 3seq
  97     [ "" concat-as ] action ;
  98
  99 : normal-float ( -- parser )
 100     [ sign optional , decdigit digits , exponent , ] seq*
 101     [ sign optional , decdigit digits , "." token , decdigit digits , exponent optional , ] seq*
 102     2choice [ "" concat-as string>number ] action ;
 103
 104 : +inf ( -- parser )
 105     "+inf" token "inf" token 2choice [ drop 1/0. ] action ;
 106
 107 : -inf ( -- parser )
 108     "-inf" token [ drop -1/0. ] action ;
 109
 110 : nan ( -- parser )
 111     sign optional "nan" token 2seq [ drop 0/0. ] action ;
 112
 113 : float-parser ( -- parser )
 114     normal-float +inf -inf nan 4choice ;
 115
 116 : number-parser ( -- parser )
 117     +inf -inf nan
 118     [ blank? not ] satisfy repeat1 [ string>number ] action
 119     4choice ;
 120
 121 : escaped ( -- parser )
 122     "\\" token hide [ "\"\\befnrt" member-eq? ] satisfy 2seq
 123     [ first escape ] action ;
 124
 125 : unicode ( -- parser )
 126     "\\u" token hide hexdigit 4 exactly-n 2seq
 127     "\\U" token hide hexdigit 8 exactly-n 2seq
 128     2choice [ first hex> ] action ;
 129
 130 : hexescape ( -- parser )
 131     "\\x" token hide hexdigit 2 exactly-n 2seq
 132     "\\X" token hide hexdigit 2 exactly-n 2seq
 133     2choice [ first hex> ] action ;
 134
 135 : basic-string ( -- parser )
 136     escaped unicode hexescape [ "\"\n" member? not ] satisfy
 137     4choice repeat0 "\"" dup surrounded-by ;
 138
 139 : literal-string ( -- parser )
 140     [ "'" member? not ] satisfy repeat0 "'" dup surrounded-by ;
 141
 142 : single-string ( -- parser )
 143     basic-string literal-string 2choice [ "" like ] action ;
 144
 145 : multi-basic-string ( -- parser )
 146     escaped unicode [ CHAR: \" = not ] satisfy 3choice repeat0
 147     "\"\"\"" dup surrounded-by ;
 148
 149 : multi-literal-string ( -- parser )
 150     [ CHAR: ' = not ] satisfy repeat0 "'''" dup surrounded-by ;
 151
 152 : multi-string ( -- parser )
 153     multi-basic-string multi-literal-string 2choice [
 154         "" like "\n" ?head drop
 155         R/ \\[ \t\r\n]*\n[ \t\r\n]*/m "" re-replace
 156     ] action ;
 157
 158 : string-parser ( -- parser )
 159     multi-string single-string 2choice ;
 160
 161 : non-ascii ( -- parser )
 162     0x80 0xd7ff range 0xe000 0x10ffff range 2choice ;
 163
 164 : comment-char ( -- parser )
 165     0x01 0x09 range 0x0e 0x7f range non-ascii 3choice ;
 166
 167 : comment ( -- parser )
 168     "#" token comment-char repeat0 2seq hide ;
 169
 170 : ws-comment-newline ( -- parser )
 171     ws comment optional 2seq newline list-of ;
 172
 173 : date-parser ( -- parser )
 174     [
 175         decdigit 4 exactly-n ,
 176         "-" token ,
 177         decdigit 2 exactly-n ,
 178         "-" token ,
 179         decdigit 2 exactly-n ,
 180     ] seq* [ "" concat-as ] action ;
 181
 182 : time-parser ( -- parser )
 183     [
 184         decdigit 2 exactly-n ,
 185         ":" token ,
 186         decdigit 2 exactly-n ,
 187         ":" token ,
 188         decdigit 2 exactly-n ,
 189         "." token decdigit repeat1 2seq optional [ concat ] action ,
 190     ] seq* [ "" concat-as ] action ;
 191
 192 : timezone-parser ( -- parser )
 193     "Z" token
 194     "+" token "-" token 2choice
 195     decdigit 2 exactly-n ":" token
 196     decdigit 2 exactly-n 4seq [ "" concat-as ] action
 197     2choice ;
 198
 199 : datetime-parser ( -- parser )
 200     [
 201         date-parser ,
 202         "T" token "t" token " " token 3choice ,
 203         time-parser ,
 204         timezone-parser optional ,
 205     ] seq* [ "" concat-as rfc3339>timestamp ] action ;
 206
 207 : separator ( -- parser )
 208     "," token comment optional 2seq ;
 209
 210 DEFER: value-parser
 211
 212 : array-value-parser ( -- parser )
 213     ws-comment-newline hide
 214     value-parser optional
 215     ws-comment-newline hide 3seq [ first ] action ;
 216
 217 : array-parser ( -- parser )
 218     [
 219         "[" token hide ,
 220         array-value-parser separator list-of [ sift ] action ,
 221         "]" token hide ,
 222     ] seq* [ first { } like ] action ;
 223
 224 DEFER: key-value-parser
 225
 226 : inline-table-key-value ( -- parser )
 227     ws-comment-newline hide
 228     key-value-parser
 229     ws-comment-newline hide 3seq [ first ] action ;
 230
 231 : inline-table-parser ( -- parser )
 232     [
 233         "{" token hide ,
 234         inline-table-key-value separator list-of ,
 235         separator optional hide ,
 236         ws-comment-newline hide ,
 237         "}" token hide ,
 238     ] seq* [
 239         first [ length <hashtable> ] keep [ update-toml ] each
 240     ] action ;
 241
 242 : value-parser ( -- parser )
 243     [
 244         [
 245             array-parser ,
 246             boolean-parser ,
 247             datetime-parser ,
 248             date-parser ,
 249             time-parser ,
 250             float-parser ,
 251             integer-parser ,
 252             string-parser ,
 253             inline-table-parser ,
 254         ] choice*
 255     ] delay ;
 256
 257 : unquoted-key ( -- parser )
 258     [
 259         CHAR: A CHAR: Z range ,
 260         CHAR: a CHAR: z range ,
 261         CHAR: 0 CHAR: 9 range ,
 262         [ "_-\xb2\xb3\xb9\xbc\xbd\xbe" member? ] satisfy ,
 263         0xC0 0XD6 range ,
 264         0xD8 0xF6 range ,
 265         0xF8 0x37D range ,
 266         0x37F 0x1FFF range ,
 267         0x200C 0x200D range ,
 268         0x203F 0x2040 range ,
 269         0x2070 0x218F range ,
 270         0x2460 0x24FF range ,
 271         0x2C00 0x2FEF range ,
 272         0x3001 0xD7FF range ,
 273         0xF900 0xFDCF range ,
 274         0xFDF0 0xFFFFD range ,
 275         0x10000 0xEFFFF range ,
 276     ] choice* repeat1 [ "" like ] action single-string 2choice ;
 277
 278 : quoted-key ( -- parser )
 279     multi-string single-string 2choice ;
 280
 281 : simple-key ( -- parser )
 282     unquoted-key quoted-key 2choice ;
 283
 284 : key-parser ( -- parser )
 285     simple-key ws "." token ws 3seq list-of ;
 286
 287 : key-value-parser ( -- parser )
 288     [
 289         key-parser ,
 290         ws hide ,
 291         "=" token hide ,
 292         ws hide ,
 293         value-parser ,
 294     ] seq* [ first2 entry boa ] action ;
 295
 296 :: table-name-parser ( begin end array? -- parser )
 297     [
 298         begin token hide ,
 299         ws hide ,
 300         key-parser ,
 301         ws hide ,
 302         end token hide ,
 303     ] seq* [ first array? table boa ] action ;
 304
 305 : array-table ( -- parser )
 306     "[[" "]]" t table-name-parser ;
 307
 308 : std-table ( -- parser )
 309     "[" "]" f table-name-parser ;
 310
 311 : table-parser ( -- parser )
 312     array-table std-table 2choice ;
 313
 314 PEG: parse-toml ( string -- ast )
 315     ws hide key-value-parser ws hide comment optional hide 4seq
 316     ws hide table-parser ws hide comment optional hide 4seq
 317     ws hide comment optional hide 2seq
 318     3choice newline list-of [ { } concat-as ] action ;
 319
 320 PRIVATE>
 321
 322 : toml> ( string -- assoc )
 323     [ H{ } clone dup ] dip parse-toml [ update-toml ] each drop ;
 324
 325 : path>toml ( path -- assoc )
 326     utf8 file-contents toml> ;