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

feat(encoder): inline tables

This commit is contained in:
hylo 2022-12-30 17:53:13 +01:00
parent 44a0b29d22
commit 0f95d9315e
2 changed files with 102 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
test/test-encoder.scm
View File

@ -1,16 +1,23 @@
#!/usr/bin/env -S guile -s #!/usr/bin/env -S guile -s
!# !#
(use-modules (use-modules
(toml parser) (toml builder)
(json) (json))
(ice-9 match)
(ice-9 textual-ports) (define test-value?
(ice-9 pretty-print)) (lambda (expr)
(and
(string? (car expr)))
(or
(vector? (cdr expr))
(equal? (map car (cdr expr)) '("value" "type")))))
(set-port-conversion-strategy! (current-input-port) 'error) (set-port-conversion-strategy! (current-input-port) 'error)
;; (define str (get-string-all (current-input-port)))
(define scm (json->scm (current-input-port))) (define scm (json->scm (current-input-port)))
(display scm)
;;(value->scm test-value->scm)
(define x (parameterize ((value? test-value?))
(scm->toml scm)))
;; (scm->toml scm)

141
toml/builder.scm
View File

@ -4,10 +4,9 @@
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:export (scm->toml)) #:export (scm->toml value?))
(define-syntax-rule (log-exprs exp ...) (begin (format (current-error-port) "~a: ~S\n" (quote exp) exp) ...))
(define-syntax-rule (log-exprs exp ...) (begin (format #t "~a: ~S\n" (quote exp) exp) ...))
;; we want to be able to dynamically bind this functin in test-decoder.scm ;; we want to be able to dynamically bind this functin in test-decoder.scm
;; TODO fix duplicate ;; TODO fix duplicate
@ -21,26 +20,16 @@
(when newline? (when newline?
(newline port))) (newline port)))
(define* (build-object-pair p port #:key (newline? #f) (inline? #f))
(define (build-object-pair p port)
(put-string port (car p)) (put-string port (car p))
(put-string port " = ") (put-string port " = ")
(toml-build (cdr p) port)) (toml-build (cdr p) port #:newline? newline? #:inline? inline?))
(define (toml-build-string s port) (define (toml-build-string s port)
(put-string port "\"") (put-string port "\"")
(put-string port s) (put-string port s)
(put-string port "\"")) (put-string port "\""))
;; (define (values-first a b)
;; (let ((av? ((value?) a))
;; (bv? ((value?) b)))
;; (cond
;; ((and av? bv?) #t)
;; (av? #t)
;; (bv? #f))))
(define (build-keys lst port) (define (build-keys lst port)
;; TODO unicode keys ;; TODO unicode keys
(put-string port (string-join lst "."))) (put-string port (string-join lst ".")))
@ -54,36 +43,68 @@
(toml-build (cdr scm) port new-table)) (toml-build (cdr scm) port new-table))
(define (toml-build-tree scm port current-table) (define (toml-build-tree scm port current-table)
(let ((pairs scm)) (define pairs scm)
(unless (null? pairs) (unless (null? pairs)
(receive (keyvals tables) (receive (keyvals tables)
(partition (value?) pairs) (partition (value?) pairs)
(for-each (lambda (kv) (for-each (lambda (kv)
(build-object-pair kv port)) (build-object-pair kv port))
keyvals) keyvals)
(for-each (lambda (t) (for-each (lambda (t)
(build-table t port current-table)) (build-table t port current-table))
tables))))) tables))))
(define (build-delimited lst port)
(let loop ((lst lst))
(if (null? (cdr lst))
(toml-build (car lst) port #:newline? #f #:inline? #t)
(begin (toml-build (car lst) port #:newline? #f #:inline? #t)
(put-string port ", ")
(loop (cdr lst))))))
(define (build-delimited-pairs lst port)
(let loop ((lst lst))
(if (null? (cdr lst))
(build-object-pair (car lst) port #:newline? #f #:inline? #t)
(begin (build-object-pair (car lst) port #:newline? #f #:inline? #t)
(put-string port ", ")
(loop (cdr lst))))))
(define (toml-build-inline-tree scm port)
;; (log-exprs scm)
(define pairs scm)
(put-string port "{")
(unless (null? pairs)
(build-delimited-pairs pairs port))
;; (build-delimited pairs port))
(put-string port "}"))
;; (build-object-pair (car pairs) port) ;; (build-object-pair (car pairs) port)
;; (for-each (lambda (p) ;; (for-each (lambda (p)
;; (build-object-pair p port)) ;; (build-object-pair p port))
;; (cdr pairs)) ;; (cdr pairs))
;; (newline port)))) ;; (newline port))))
(define (toml-build-array v port) (define (toml-build-array v port)
(put-string port "[") (put-string port "[")
(let loop ((lst (vector->list v))) (build-delimited (vector->list v) port)
(if (null? (cdr lst))
(toml-build (car lst) port #:newline? #f)
(begin (toml-build (car lst) port #:newline? #f)
(put-string port ", ")
(loop (cdr lst)))))
(put-string port "]")) (put-string port "]"))
;; (define (toml-build-value scm port)
;; (cond
;; ;; ((eq? scm null) (toml-build-null port))
;; ;; ((boolean? scm) (toml-build-boolean scm port))
;; ;; ((toml-number? scm) (toml-build-number scm port))
;; ;; ((symbol? scm) (toml-build-string (symbol->string scm) port))
;; ((string? scm) (toml-build-string scm port))
;; ((vector? scm) (toml-build-array scm port))
;; ((or (pair? scm) (null? scm))
;; (toml-build-tree scm port current-table)))
;; (build-newline port newline?))
(define* (toml-build scm port #:optional (current-table '()) (define* (toml-build scm port #:optional (current-table '())
#:key (newline? #t)) #:key (newline? #t) (inline? #f))
;; (log-exprs scm) ;; (log-exprs scm)
(cond (cond
;; ((eq? scm null) (toml-build-null port)) ;; ((eq? scm null) (toml-build-null port))
@ -93,7 +114,10 @@
((string? scm) (toml-build-string scm port)) ((string? scm) (toml-build-string scm port))
((vector? scm) (toml-build-array scm port)) ((vector? scm) (toml-build-array scm port))
((or (pair? scm) (null? scm)) ((or (pair? scm) (null? scm))
(toml-build-tree scm port current-table))) (if inline?
(toml-build-inline-tree scm port)
(toml-build-tree scm port current-table))))
(build-newline port newline?)) (build-newline port newline?))
;; (else (throw 'toml-invalid scm)))) ;; (else (throw 'toml-invalid scm))))
@ -103,26 +127,35 @@
;; (scm->toml '(("a" . "b") ("c" . "d"))) ;; (scm->toml '(("a" . "b") ("c" . "d")))
;; (scm->toml '(("yo" ("a" . "b")))) ;; (scm->toml '(("yo" ("a" . "b"))))
(scm->toml '(("hi" ;; (scm->toml '(("hi"
("yo" ("a" . "b") ("c" . "d")) ;; ("yo" ("a" . "b") ("c" . "d"))
;; ("e" . #("f" "b" (("a" . "b")))) TODO inline-tables ;; ;; ("e" . #("f" "b" (("a" . "b")))) TODO inline-tables
("e" . #("f" "b" "g"))) ;; ("e" . #("f" "b" "g")))
("g" . "p"))) ;; ("g" . "p")))
'(("servers" ;; '(("servers"
("beta" ("role" . "backend") ("ip" . "10.0.0.2")) ;; ("beta" ("role" . "backend") ("ip" . "10.0.0.2"))
("alpha" ;; ("alpha"
("role" . "frontend") ;; ("role" . "frontend")
("ip" . "10.0.0.1"))) ;; ("ip" . "10.0.0.1")))
("database" ;; ("database"
("temp_targets" ("case" . 72.0) ("cpu" . 79.5)) ;; ("temp_targets" ("case" . 72.0) ("cpu" . 79.5))
("data" . #(#("delta" "phi") #(3.14))) ;; ("data" . #(#("delta" "phi") #(3.14)))
("ports" . #(8000 8001 8002)) ;; ("ports" . #(8000 8001 8002))
("enabled" . #t)) ;; ("enabled" . #t))
("owner" ;; ("owner"
("dob" ;; ("dob"
. "date") ;; . "date")
("name" . "Tom Preston-Werner")) ;; ("name" . "Tom Preston-Werner"))
("title" . "TOML Example")) ;; ("title" . "TOML Example"))
'() ;; '()
;; (define (values-first a b)
;; (let ((av? ((value?) a))
;; (bv? ((value?) b)))
;; (cond
;; ((and av? bv?) #t)
;; (av? #t)
;; (bv? #f))))