1 ! Copyright (C) 2019 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors assocs hashtables kernel make math.parser peg
5 peg.parsers regexp sequences splitting strings.parser ;
9 ERROR: duplicate-key key ;
11 ERROR: unknown-value value ;
15 ! FIXME: key = 1234abcd # should error!
17 TUPLE: table name array? entries ;
19 TUPLE: entry key value ;
21 : boolean-parser ( -- parser )
22 "true" token [ drop t ] action
23 "false" token [ drop f ] action
26 : digits ( parser -- parser )
27 "_" token [ drop f ] action 2choice repeat1 [ sift ] action ;
30 "+" token "-" token 2choice ;
32 : hexdigit ( -- parser )
34 CHAR: 0 CHAR: 9 range ,
35 CHAR: a CHAR: f range ,
36 CHAR: A CHAR: F range ,
40 "0x" token hide hexdigit digits 2seq [ first hex> ] action ;
42 : decdigit ( -- parser )
43 CHAR: 0 CHAR: 9 range ;
46 decdigit digits [ dec> ] action ;
48 : octdigit ( -- parser )
49 CHAR: 0 CHAR: 7 range ;
52 "0o" token hide octdigit digits 2seq [ first oct> ] action ;
54 : bindigit ( -- parser )
55 CHAR: 0 CHAR: 1 range ;
58 "0b" token hide bindigit digits 2seq [ first bin> ] action ;
60 : integer-parser ( -- parser )
61 hex oct bin dec 4choice ;
66 decdigit digits optional ,
68 decdigit digits optional ,
69 "e" token "E" token 2choice
71 decdigit digits optional 3seq optional ,
72 ] seq* [ unclip-last append "" concat-as string>number ] action ;
75 "+" token optional "inf" token 2seq [ drop 1/0. ] action ;
78 "-inf" token [ drop -1/0. ] action ;
81 sign optional "nan" token 2seq
82 [ drop NAN: 8000000000000 ] action ;
84 : float-parser ( -- parser )
85 float +inf -inf nan 4choice ;
87 : escaped ( -- parser )
88 "\\" token hide [ "btnfr\"\\" member-eq? ] satisfy 2seq
89 [ first escape ] action ;
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 ;
96 : basic-string ( -- parser )
97 escaped unicode [ "\"\n" member? not ] satisfy 3choice repeat0
98 "\"" dup surrounded-by ;
100 : literal-string ( -- parser )
101 [ "'\n" member? not ] satisfy repeat0
102 "'" dup surrounded-by ;
104 : single-string ( -- parser )
105 basic-string literal-string 2choice [ "" like ] action ;
107 : multi-basic-string ( -- parser )
108 escaped unicode [ CHAR: \" = not ] satisfy 3choice repeat0
109 "\"\"\"" dup surrounded-by ;
111 : multi-literal-string ( -- parser )
112 [ CHAR: ' = not ] satisfy repeat0
113 "'''" dup surrounded-by ;
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
121 : string-parser ( -- parser )
122 multi-string single-string 2choice ;
124 : date-parser ( -- parser )
126 decdigit 4 exactly-n ,
128 decdigit 2 exactly-n ,
130 decdigit 2 exactly-n ,
131 ] seq* [ "" concat-as ] action ;
133 : time-parser ( -- parser )
135 decdigit 2 exactly-n ,
137 decdigit 2 exactly-n ,
139 decdigit 2 exactly-n ,
140 "." token decdigit repeat1 2seq optional ,
141 ] seq* [ "" concat-as ] action ;
143 : timezone-parser ( -- parser )
146 decdigit 2 exactly-n ":" token
147 decdigit 2 exactly-n 4seq [ "" concat-as ] action
150 : datetime-parser ( -- parser )
153 "T" token " " token 2choice ,
155 timezone-parser optional ,
156 ] seq* [ "" concat-as ] action ;
158 : space ( -- parser )
159 [ " \t" member? ] satisfy repeat0 ;
161 : whitespace ( -- parser )
162 [ " \t\r\n" member? ] satisfy repeat0 ;
166 : array-parser ( -- parser )
171 whitespace "," token whitespace pack list-of ,
174 ] seq* [ first { } like ] action ;
176 DEFER: key-value-parser
180 : inline-table-parser ( -- parser )
185 whitespace "," token whitespace pack list-of ,
189 first [ length <hashtable> ] keep [ update-toml ] each
192 : value-parser ( -- parser )
203 inline-table-parser ,
207 : name-parser ( -- parser )
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 ;
216 : comment-parser ( -- parser )
220 [ CHAR: \n = not ] satisfy repeat0 ,
221 ] seq* [ drop f ] action ;
223 : key-parser ( -- parser )
224 name-parser "." token list-of [ { } like ] action ;
226 : key-value-parser ( -- parser )
234 comment-parser optional hide ,
235 ] seq* [ first2 entry boa ] action ;
237 : line-parser ( -- parser )
238 "\n" token "\r\n" token 2choice ;
240 :: table-name-parser ( begin end -- parser )
245 space "." token space pack list-of
246 [ { } like ] action ,
249 comment-parser optional hide ,
252 : table-parser ( -- parser )
255 "[[" "]]" table-name-parser [ t suffix! ] action
256 "[" "]" table-name-parser [ f suffix! ] action
259 key-value-parser line-parser list-of optional ,
260 ] seq* [ first2 [ first2 ] dip table boa ] action ;
262 : toml-parser ( -- parser )
269 ] choice* whitespace list-of ,
271 ] seq* [ first sift { } like ] action ;
273 : check-no-key ( key assoc -- key assoc )
274 2dup at* nip [ over duplicate-key ] when ;
276 : deep-at ( keys assoc -- value )
279 H{ } clone [ swap rot check-no-key set-at ] keep
283 GENERIC: update-toml ( assoc entry -- assoc )
286 [ key>> unclip-last [ over deep-at ] dip ] [ value>> ] bi
287 swap rot check-no-key set-at ;
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 ;
296 : toml> ( string -- assoc )
297 [ H{ } clone ] dip toml-parser parse [ update-toml ] each ;