308 lines
8.9 KiB
Scheme
308 lines
8.9 KiB
Scheme
(define-module (toml parser-peg)
|
|
#:use-module (ice-9 peg)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:export (parse))
|
|
|
|
;; Built-in ABNF terms, reproduced here for clarity
|
|
(define-peg-string-patterns
|
|
"ALPHA <- [A-Z] / [a-z]
|
|
DIGIT <- [0-9]
|
|
HEXDIG <- DIGIT / [A-Fa-f]
|
|
")
|
|
;; T-Newline
|
|
(define-peg-string-patterns
|
|
"t-newline < '\n' / '\r\n'")
|
|
|
|
(define-peg-string-patterns
|
|
"toml <- (t-expression t-newline)* t-expression
|
|
t-expression <- ((ws keyval ws) / (ws table ws) / ws) comment?
|
|
")
|
|
|
|
;; Whitespace
|
|
(define-peg-string-patterns
|
|
"ws < wschar*
|
|
wschar < ' ' / '\t'
|
|
")
|
|
;; Comment
|
|
;; non-ascii <- %x80-D7FF / %xE000-10FFFF
|
|
;; non-eol <- %x09 / %x20-7F / non-ascii
|
|
|
|
(define-peg-pattern non-ascii body
|
|
(or (range #\x80 #\xD7FF) (range #\xE000 #\x10FFFF)))
|
|
(define-peg-pattern non-eol body
|
|
;; TODO report abnf is wrong here?
|
|
(or "\t" (range #\x20 #\x7E) non-ascii))
|
|
|
|
(define-peg-string-patterns
|
|
"comment-start-symbol <- '#'
|
|
|
|
comment < comment-start-symbol non-eol*
|
|
")
|
|
;; Key-Value pairs
|
|
|
|
(define-peg-string-patterns
|
|
"keyval <-- key keyval-sep val
|
|
key <- dotted-key / simple-key
|
|
simple-key <-- quoted-key / unquoted-key
|
|
|
|
unquoted-key <- (ALPHA / DIGIT / '-' / '_')+
|
|
quoted-key <- basic-string / literal-string
|
|
dotted-key <- simple-key ( dot-sep simple-key )+
|
|
|
|
dot-sep <- ws dot ws
|
|
dot < '.'
|
|
keyval-sep <- ws eq ws
|
|
eq < '='
|
|
val <- string / bool / array / inline-table / date-time / float / integer
|
|
|
|
")
|
|
;; String
|
|
(define-peg-string-patterns
|
|
"string <-- ml-basic-string / basic-string / ml-literal-string / literal-string
|
|
")
|
|
;; Basic String
|
|
(define-peg-string-patterns
|
|
"basic-string <- quotation-mark basic-char* quotation-mark
|
|
|
|
quotation-mark < '\"'
|
|
|
|
basic-char <- basic-unescaped / escaped
|
|
")
|
|
|
|
;; basic-unescaped <- wschar / %x21 / %x23-5B / %x5D-7E / non-ascii
|
|
(define-peg-pattern basic-unescaped body
|
|
(or body-wschar (range #\x21 #\x21) (range #\x23 #\x5B) (range #\x5D #\x7E) non-ascii))
|
|
(define-peg-string-patterns
|
|
"escaped <-- escape escape-seq-char
|
|
|
|
escape <- '\\'
|
|
")
|
|
|
|
(define-peg-pattern escape-seq-char body
|
|
(or
|
|
"\""
|
|
"\\"
|
|
"b"
|
|
"f"
|
|
"n"
|
|
"r"
|
|
"t"
|
|
(and (range #\u #\u) HEXDIG HEXDIG HEXDIG HEXDIG)
|
|
(and (range #\U #\U) HEXDIG HEXDIG HEXDIG HEXDIG HEXDIG HEXDIG HEXDIG HEXDIG)))
|
|
|
|
;; escape-seq-char <- %x22 ; quotation mark U+0022
|
|
;; escape-seq-char =/ %x5C ; reverse solidus U+005C
|
|
;; escape-seq-char =/ %x62 ; b backspace U+0008
|
|
;; escape-seq-char =/ %x66 ; f form feed U+000C
|
|
;; escape-seq-char =/ %x6E ; n line feed U+000A
|
|
;; escape-seq-char =/ %x72 ; r carriage return U+000D
|
|
;; escape-seq-char =/ %x74 ; t tab U+0009
|
|
;; escape-seq-char =/ %x75 4HEXDIG ; uXXXX U+XXXX
|
|
;; escape-seq-char =/ %x55 8HEXDIG ; UXXXXXXXX U+XXXXXXXX
|
|
;; ))
|
|
|
|
|
|
|
|
|
|
;; Multiline Basic String
|
|
(define-peg-string-patterns
|
|
"ml-basic-string <- ml-basic-string-delim t-newline? ml-basic-body ml-basic-string-delim
|
|
ml-basic-string-delim <- quotation-mark quotation-mark quotation-mark
|
|
ml-basic-body <- mlb-content* (mlb-quotes mlb-content+)* mlb-quotes-end?
|
|
|
|
mlb-quotes-end <- mlb-quotes-end-2 / mlb-quotes-end-1
|
|
mlb-quotes-end-1 <- body-quot &ml-basic-string-delim
|
|
mlb-quotes-end-2 <- body-quot body-quot &ml-basic-string-delim
|
|
|
|
body-newline <- '\n' / '\r\n'
|
|
body-ws <- body-wschar*
|
|
body-wschar <- ' ' / '\t'
|
|
body-quot <- '\"'
|
|
|
|
mlb-content <- mlb-escaped-nl / mlb-char / body-newline
|
|
mlb-char <- mlb-unescaped / escaped
|
|
mlb-quotes <- !ml-basic-string-delim body-quot body-quot?
|
|
mlb-escaped-nl < escape ws body-newline (wschar / body-newline)*
|
|
")
|
|
;; mlb-unescaped <- wschar / %x21 / %x23-5B / %x5D-7E / non-ascii
|
|
(define-peg-pattern mlb-unescaped body
|
|
(or body-wschar (range #\x21 #\x21) (range #\x23 #\x5B) (range #\x5D #\x7E) non-ascii))
|
|
|
|
;; Literal String
|
|
(define-peg-string-patterns
|
|
"literal-string <- apostrophe literal-char* apostrophe
|
|
")
|
|
|
|
;; apostrophe <- '\x27' ; apostrophe
|
|
;; literal-char <- %x09 / %x20-26 / %x28-7E / non-ascii
|
|
(define-peg-pattern apostrophe none "'")
|
|
(define-peg-pattern body-apostrophe body "'")
|
|
(define-peg-pattern literal-char body
|
|
(or "\t" (range #\x20 #\x26) (range #\x28 #\x7E) non-ascii))
|
|
|
|
;; Multiline Literal String
|
|
(define-peg-string-patterns
|
|
"mll-quotes <- !ml-literal-string-delim body-apostrophe body-apostrophe?
|
|
|
|
mll-quotes-end <- mll-quotes-end-2 / mll-quotes-end-1
|
|
mll-quotes-end-1 <- body-apostrophe &ml-literal-string-delim
|
|
mll-quotes-end-2 <- body-apostrophe body-apostrophe &ml-literal-string-delim
|
|
|
|
ml-literal-string <- ml-literal-string-delim t-newline? ml-literal-body ml-literal-string-delim
|
|
ml-literal-string-delim <- apostrophe apostrophe apostrophe
|
|
ml-literal-body <- mll-content* (mll-quotes mll-content+ )* mll-quotes-end?
|
|
|
|
mll-content <- mll-char / body-newline
|
|
")
|
|
|
|
(define-peg-pattern mll-char body
|
|
(or "\t" (range #\x20 #\x26) (range #\x28 #\x7E) non-ascii))
|
|
;; Integer
|
|
(define-peg-string-patterns
|
|
"integer <-- hex-int / oct-int / bin-int / dec-int
|
|
|
|
minus <- '-'
|
|
plus < '+'
|
|
underscore < '_'
|
|
digit1-9 <- [1-9]
|
|
digit0-7 <- [0-9]
|
|
digit0-1 <- [0-1]
|
|
|
|
hex-prefix <- '0x'
|
|
oct-prefix <- '0o'
|
|
bin-prefix <- '0b'
|
|
|
|
dec-int <- (minus / plus)? unsigned-dec-int
|
|
unsigned-dec-int <- (digit1-9 ( DIGIT / (underscore DIGIT))+) / DIGIT
|
|
|
|
hex-int <- hex-prefix HEXDIG (HEXDIG / underscore HEXDIG)*
|
|
oct-int <- oct-prefix digit0-7 (digit0-7 / underscore digit0-7)*
|
|
bin-int <- bin-prefix digit0-1 (digit0-1 / underscore digit0-1)*
|
|
")
|
|
;; Float
|
|
(define-peg-string-patterns
|
|
"float <-- (float-int-part ( t-exp / frac t-exp?)) / special-float
|
|
|
|
float-dec-int <- (minus / plus)? unsigned-dec-int
|
|
float-int-part <- float-dec-int
|
|
frac <- decimal-point zero-prefixable-int
|
|
decimal-point <- '.'
|
|
zero-prefixable-int <- DIGIT (DIGIT / underscore DIGIT)*
|
|
|
|
t-exp <- [eE] float-t-exp-part
|
|
float-t-exp-part <- (minus / plus)? zero-prefixable-int
|
|
|
|
minus-none < '-'
|
|
plus-none < '+'
|
|
t-nan <- 'nan'
|
|
t-inf <- 'inf'
|
|
|
|
special-float <- ((minus / plus)? t-inf) / ((minus-none / plus-none)? t-nan)
|
|
|
|
")
|
|
;; Boolean
|
|
(define-peg-string-patterns
|
|
"bool <-- 'true' / 'false'
|
|
|
|
")
|
|
;; true <- %x74.72.75.65 ; true
|
|
;; false <- %x66.61.6C.73.65 ; false
|
|
|
|
;; Date and Time (as defined in RFC 3339)
|
|
(define-peg-string-patterns
|
|
"date-time <- datetime / datetime-local / date-local / time-local
|
|
|
|
date-fullyear <- DIGIT DIGIT DIGIT DIGIT
|
|
date-month <- DIGIT DIGIT
|
|
date-mday <- DIGIT DIGIT
|
|
time-delim <- 'T' / 't' / ' '
|
|
time-hour <- DIGIT DIGIT
|
|
time-minute <- DIGIT DIGIT
|
|
time-second <- DIGIT DIGIT
|
|
time-secfrac <- '.' DIGIT+
|
|
time-numoffset <- ( '+' / '-' ) time-hour ':' time-minute
|
|
time-offset <- 'Z' / 'z' / time-numoffset
|
|
|
|
partial-time <- time-hour ':' time-minute ':' time-second time-secfrac?
|
|
full-date <- date-fullyear '-' date-month '-' date-mday
|
|
full-time <- partial-time time-offset
|
|
")
|
|
;; time-delim <- 'T' / ' ' ; T, t, or space
|
|
|
|
;; Offset Date-Time
|
|
(define-peg-string-patterns
|
|
"datetime <-- full-date time-delim full-time
|
|
")
|
|
;; Local Date-Time
|
|
(define-peg-string-patterns
|
|
"datetime-local <-- full-date time-delim partial-time
|
|
")
|
|
;; Local Date
|
|
(define-peg-string-patterns
|
|
"date-local <-- full-date
|
|
")
|
|
;; Local Time
|
|
(define-peg-string-patterns
|
|
"time-local <-- partial-time
|
|
")
|
|
;; Array
|
|
;; array-values <- ws-comment-t-newline val ws-comment-t-newline array-sep array-values / ws-comment-t-newline val ws-comment-t-newline array-sep?
|
|
;; array-values <- (ws-comment-t-newline val ws-comment-t-newline array-sep)* ws-comment-t-newline val ws-comment-t-newline array-sep?
|
|
(define-peg-string-patterns
|
|
"array <-- array-open array-values? ws-comment-t-newline array-close
|
|
|
|
array-open < '['
|
|
array-close < ']'
|
|
|
|
array-values <- array-values-1 / array-values-2
|
|
array-values-1 <- ws-comment-t-newline val ws-comment-t-newline array-sep array-values
|
|
array-values-2 <- ws-comment-t-newline val ws-comment-t-newline array-sep?
|
|
|
|
array-sep < ','
|
|
|
|
ws-comment-t-newline <- ((comment? t-newline) / wschar)*
|
|
")
|
|
;; Table
|
|
(define-peg-string-patterns
|
|
"table <- std-table / array-table
|
|
")
|
|
;; Standard Table
|
|
(define-peg-string-patterns
|
|
"std-table <-- std-table-open key std-table-close
|
|
|
|
std-table-open < '[' ws
|
|
std-table-close < ws ']'
|
|
")
|
|
;; Inline Table
|
|
(define-peg-string-patterns
|
|
"inline-table <-- inline-table-open (inline-table-keyvals / empty) inline-table-close
|
|
|
|
empty <- ''
|
|
inline-table-open < '{' ws
|
|
inline-table-close < ws '}'
|
|
inline-table-sep < ws ',' ws
|
|
|
|
inline-table-keyvals <- keyval (inline-table-sep inline-table-keyvals)?
|
|
")
|
|
;; Array Table
|
|
(define-peg-string-patterns
|
|
"array-table <-- array-table-open key array-table-close
|
|
|
|
array-table-open < '[[' ws
|
|
array-table-close < ws ']]'
|
|
")
|
|
|
|
|
|
(define (parse str)
|
|
;; (define record (keyword-flatten
|
|
;; '(keyval std-table inline-table)
|
|
;; (match-pattern toml str)))
|
|
(define peg (match-pattern toml str))
|
|
(if (eq? (string-length str) (peg:end peg))
|
|
(begin
|
|
;; (pretty-print (peg:tree record))
|
|
(peg:tree peg))
|
|
(begin
|
|
(pretty-print (peg:tree peg))
|
|
(error "guile-toml: parsing failed\n" (peg:substring peg)))))
|