basis/toml/toml.factor

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