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

refactor: use Parameters for dynamic binding for tests

This commit is contained in:
hylo 2022-12-30 17:53:13 +01:00
parent eac19664d4
commit 05dd32b224
2 changed files with 60 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
test-decoder.scm
View File

@ -1,7 +1,35 @@
#!/usr/bin/env -S guile -s
!#
(use-modules (json) (toml) (ice-9 textual-ports))
(use-modules (json) (toml) (ice-9 match) (ice-9 textual-ports))
(define scm (toml->scm (get-string-all (current-input-port))))
(define test-value->scm
(lambda (v)
(match v
(('array vs ...)
;; (pretty-print (flatten-array vs))
(list->vector (map test-value->scm (flatten-array vs))))
;; (format #f "array ~a" (flatten-array vs)))
((x y)
;; (single-value-proc x y)
`(("value" . ,y) ("type" . ,(symbol->string x))))
;; (format #f "type: ~a, value: ~a" x y))
('()
'())
;; ('inline-table
;; '())
(_ (error "err: ~a" v)))))
(define test-value?
(lambda (expr)
(and
(string? (car expr))
(equal? (map car (cdr expr)) '("value" "type")))))
(define str (get-string-all (current-input-port)))
(define scm (parameterize ((value->scm test-value->scm)
(value? test-value?))
(toml->scm str)))
(define json (scm->json scm #:pretty #t))

68
toml.scm
View File

@ -6,7 +6,8 @@
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (srfi srfi-1)
#:export (toml->scm))
;; TODO exporting flatten-array isn't nice, it's an internal function.
#:export (toml->scm flatten-array value->scm value?))
(define-syntax-rule (log-exprs exp ...) (begin (format #t "~a: ~S\n" (quote exp) exp) ...))
@ -17,55 +18,50 @@
(define (get-keys l)
(map cadr (keyword-flatten '(simple-key) l)))
(define (single-value-proc x y)
y)
;; we want to be able to dynamically bind this function in test-decoder.scm
;; TODO would be nicer if we didn't have to export flatten-array
(define value->scm
(make-parameter
(lambda (v)
(match v
(('array vs ...)
;; (pretty-print (flatten-array vs))
(list->vector (map (value->scm) (flatten-array vs))))
;; (format #f "array ~a" (flatten-array vs)))
((x y)
;; (single-value-proc x y)
;; (annot-v-proc x y))
y)
;; (format #f "type: ~a, value: ~a" x y))
('()
'())
;; ('inline-table
;; '())
(_ (error "err:" v))))))
(define (annot-v-proc x y)
`(("value" . ,y) ("type" . ,(symbol->string x))))
(define (value->scm v)
(match v
(('array vs ...)
;; (pretty-print (flatten-array vs))
(list->vector (map value->scm (flatten-array vs))))
;; (format #f "array ~a" (flatten-array vs)))
((x y)
;; (single-value-proc x y)
(annot-v-proc x y))
;; (format #f "type: ~a, value: ~a" x y))
('()
'())
;; ('inline-table
;; '())
(_ (error "err: ~a" v))))
;; ((value->scm) '(x "2"))
(define (keyval->scm keys value)
(let loop ((keys keys))
(if (null? (cdr keys))
(cons (car keys) (value->scm (car value)))
(cons (car keys) ((value->scm) (car value)))
(list (car keys) (loop (cdr keys))))))
;; (define tr '(("a" ("aa" . "v")) ("b" "c")))
(define (value? expr)
(list? expr))
(define (test-value? expr)
(and
(string? (car expr))
(equal? (map car (cdr expr)) '("value" "type"))))
;; (list-index (lambda (x) (equal? x "c")) (map car tr))
;; we want to be able to dynamically bind this functin in test-decoder.scm
(define value?
(make-parameter
(lambda (expr) (not (list? expr)))))
(define (add-to-tree tree keys value)
;; (pretty-print value)
(if (null? keys)
;; TODO helper to never call this on top-level
(value->scm value)
((value->scm) value)
(let ((k (list-index (lambda (x) (equal? x (car keys))) (map car tree))))
(if k
(let ((e (list-ref tree k)))
;; (pretty-print e)
(when (test-value? e)
(when ((value?) e)
(error "guile-toml: redefinition not allowed"))
(append
(take tree k)
@ -119,7 +115,3 @@
result
(loop (cdr tree) result current-table inline-table-keys))))
;; (toml->scm "a={}\n[a]")
;; (parse "a=2")
;; (parse "[a]")