TakeV
/
guile-toml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

feat: inline-tables (wip)

This commit is contained in:
hylo 2022-12-30 17:53:13 +01:00
parent cb8c331468
commit d8993f2ebc
3 changed files with 53 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
test-decoder.scm
View File

@ -25,7 +25,10 @@
(('time-local v)
(validate-date-time `(time-local ,v))
`(("value" . ,v) ("type" . "time-local")))
(('inline-table "")
'())
(('inline-table xs ...)
(peg-tree->scm (flatten-tree xs)))
((x y)
`(("value" . ,y) ("type" . ,(symbol->string x))))
('()

62
toml.scm
View File

@ -9,7 +9,7 @@
#:use-module (json)
#:use-module (srfi srfi-1)
;; TODO exporting flatten-array isn't nice, it's an internal function.
#:export (toml->scm flatten-array value->scm validate-date-time read-string read-int value?))
#:export (toml->scm peg-tree->scm flatten-tree flatten-array value->scm validate-date-time read-string read-int value?))
(define-syntax-rule (log-exprs exp ...) (begin (format #t "~a: ~S\n" (quote exp) exp) ...))
@ -54,8 +54,13 @@
(define value->scm
(make-parameter
(lambda (value-pair)
(log-exprs value-pair)
(match value-pair
(('array value-pairs ...)
;; (log-exprs value-pairs (flatten-array value-pairs))
;; (pretty-print value-pairs)
;; (newline)
;; (pretty-print (flatten-array value-pairs))
(list->vector (map (value->scm) (flatten-array value-pairs))))
(('integer v)
(read-int v))
@ -84,6 +89,10 @@
(('time-local v)
(validate-date-time `(time-local ,v))
(time-local->date v))
(('inline-table "")
'())
(('inline-table xs ...)
(peg-tree->scm xs))
((x y)
(format #f "~a: ~a" x y))
('()
@ -343,6 +352,13 @@
;; need to refactor parsing somehow to treat recursive array / inline-table definitions
(define (toml->scm s)
(define tree (parse s))
(peg-tree->scm (flatten-tree tree)))
(define (flatten-tree tree)
(keyword-flatten '(keyval array-table std-table inline-table) tree))
(define (peg-tree->scm tree)
;; (pretty-print tree)
(let loop ((tree (if (symbol? (car tree)) (list tree) tree))
(result '())
(current-table '())
@ -354,28 +370,26 @@
;; (pretty-print result)
;; (newline)
(match (car tree)
(('keyval keys 'inline-table)
(let ((keylist (append current-table (get-keys keys))))
(when (find-key result keylist)
(error "guile-toml: redefinition not allowed"))
(set! inline-table-keys (cons keylist inline-table-keys))
(set! result (add-to-tree result current-table (get-keys keys) '(()) array-table-index))))
;; (('keyval keys 'inline-table)
;; (let ((keylist (append current-table (get-keys keys))))
;; (set! inline-table-keys (cons keylist inline-table-keys))
;; (set! result (add-to-tree result current-table (get-keys keys) '(()) array-table-index))))
(('keyval keys ('inline-table keyvals ...))
(let* ((keylist (append current-table (get-keys keys)))
(keylist-all-but-last (all-keys-but-last keylist)))
(when (not (eq? 1 (length (get-keys keys))))
(check-explicit-table-keys keylist-all-but-last explicit-table-keys (length current-table))
(set! explicit-table-keys (cons keylist-all-but-last explicit-table-keys)))
(set! result
(loop (keyword-flatten '(keyval) keyvals)
result
keylist
'()
'()
'()
'()
array-table-index))))
;; (('keyval keys ('inline-table keyvals ...))
;; (let* ((keylist (append current-table (get-keys keys)))
;; (keylist-all-but-last (all-keys-but-last keylist)))
;; (when (not (eq? 1 (length (get-keys keys))))
;; (check-explicit-table-keys keylist-all-but-last explicit-table-keys (length current-table))
;; (set! explicit-table-keys (cons keylist-all-but-last explicit-table-keys)))
;; (set! result
;; (loop (keyword-flatten '(keyval) keyvals)
;; result
;; keylist
;; '()
;; '()
;; '()
;; '()
;; array-table-index))))
(('keyval ('simple-key value)) ;; special case for key being empty string
(let* ((keylist (append current-table '(""))))
@ -390,6 +404,8 @@
;; (log-exprs explicit-table-keys keylist-all-but-last)
(check-explicit-table-keys keylist-all-but-last explicit-table-keys (length current-table))
(set! new-explicit-table-keys (cons keylist-all-but-last new-explicit-table-keys)))
;; (when (find-key result keylist)
;; (error "guile-toml: redefinition not allowed"))
(set! result (add-to-tree result current-table (get-keys keys) value array-table-index))))
(('std-table keys ...)
@ -424,7 +440,7 @@
(x (format #t "~a ; unknown: ~a\n" tree x)))
(x (error x)))
(if (null? (cdr tree))
result

18
toml/parser.scm
View File

@ -275,8 +275,9 @@ std-table-close < ws ']'
")
;; Inline Table
(define-peg-string-patterns
"inline-table <-- inline-table-open inline-table-keyvals? inline-table-close
"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
@ -293,13 +294,14 @@ array-table-close < ws ']]'
(define (parse str)
(define record (keyword-flatten
'(array keyval std-table inline-table)
(match-pattern toml str)))
(if (eq? (string-length str) (peg:end record))
;; (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 record))
(peg:tree peg))
(begin
(pretty-print (peg:tree record))
(error "guile-toml: parsing failed\n" (peg:substring record)))))
(pretty-print (peg:tree peg))
(error "guile-toml: parsing failed\n" (peg:substring peg)))))