From d8993f2ebc3579e738d681cc061cda56cefa060c Mon Sep 17 00:00:00 2001 From: hylo Date: Fri, 30 Dec 2022 17:53:13 +0100 Subject: [PATCH] feat: inline-tables (wip) --- test-decoder.scm | 5 +++- toml.scm | 62 ++++++++++++++++++++++++++++++------------------ toml/parser.scm | 18 +++++++------- 3 files changed, 53 insertions(+), 32 deletions(-) diff --git a/test-decoder.scm b/test-decoder.scm index 5bf7477..14cfc9d 100755 --- a/test-decoder.scm +++ b/test-decoder.scm @@ -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)))) ('() diff --git a/toml.scm b/toml.scm index ed9324c..76bc2f5 100644 --- a/toml.scm +++ b/toml.scm @@ -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 diff --git a/toml/parser.scm b/toml/parser.scm index 82bcbe0..e0a97f7 100644 --- a/toml/parser.scm +++ b/toml/parser.scm @@ -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)))))