316 lines
9.4 KiB
Scheme
316 lines
9.4 KiB
Scheme
;; EDN Reading
|
|
;; ===========
|
|
|
|
(define (is-char? a)
|
|
(lambda (b)
|
|
(and (char? b)
|
|
(char=? a b))))
|
|
|
|
(define (is-number? c)
|
|
(or (char-numeric? c)
|
|
(char=? #\+ c)
|
|
(char=? #\- c)))
|
|
|
|
(define (is-whitespace? c)
|
|
(or (char-whitespace? c)
|
|
(char=? #\, c)))
|
|
|
|
(define (is-endingchar? c)
|
|
(or (char=? #\# c)
|
|
(char=? #\) c)
|
|
(char=? #\] c)
|
|
(char=? #\} c)))
|
|
|
|
(define (is-symbolstarter? c)
|
|
(or (char-alphabetic? c)
|
|
(char=? #\/ c)))
|
|
|
|
(define edn->atom
|
|
(case-lambda
|
|
((skip-fn end-fn finalizer) (lambda (subparser input)
|
|
(edn->atom subparser skip-fn end-fn finalizer '() '() input)))
|
|
((subparser skip-fn end-fn finalizer result pile input)
|
|
(cond ((or (eq? #!eof (peek-char input))
|
|
(end-fn result pile input))
|
|
(cons (finalizer (reverse result))
|
|
(if (or (not (char-ready? input))
|
|
(is-endingchar? (peek-char input)))
|
|
input
|
|
(begin (read-char input) input))))
|
|
((skip-fn result pile input)
|
|
(edn->atom subparser skip-fn end-fn finalizer result (cons (read-char input) pile) input))
|
|
(else (edn->atom subparser skip-fn end-fn finalizer (cons (peek-char input) result) (cons (peek-char input) pile)
|
|
(if (null? input) input (begin (read-char input) input))))))))
|
|
|
|
(define edn->string
|
|
(edn->atom (lambda (result pile input)
|
|
(or (char=? #\\ (peek-char input))
|
|
(and (null? result)
|
|
(char=? #\" (peek-char input)))))
|
|
(lambda (result pile input)
|
|
(and (char=? #\" (peek-char input))
|
|
(not (null? pile))
|
|
(or (not (char=? #\\ (car pile)))
|
|
(char=? #\" (car pile)))))
|
|
list->string))
|
|
|
|
(define edn->keyword
|
|
(edn->atom (lambda (result pile input)
|
|
(char=? #\: (peek-char input)))
|
|
(lambda (result pile input)
|
|
(or (is-whitespace? (peek-char input))
|
|
(is-endingchar? (peek-char input))))
|
|
(lambda (in) (string->keyword (list->string in)))))
|
|
|
|
(define edn->symbol
|
|
(edn->atom (lambda (result pile input) #f)
|
|
(lambda (result pile input)
|
|
(or (is-whitespace? (peek-char input))
|
|
(is-endingchar? (peek-char input))))
|
|
(lambda (in) (let ((res-string (list->string in)))
|
|
(cond
|
|
((equal? "true" res-string) #t)
|
|
((equal? "false" res-string) #f)
|
|
((equal? "nil" res-string) '())
|
|
(else (string->symbol res-string)))))))
|
|
|
|
(define edn->number
|
|
(edn->atom (lambda (result pile input) #f)
|
|
(lambda (result pile input)
|
|
(or (is-whitespace? (peek-char input))
|
|
(is-endingchar? (peek-char input))
|
|
(char=? #\M (peek-char input))
|
|
(char=? #\N (peek-char input))))
|
|
(lambda (in) (string->number (list->string in)))))
|
|
|
|
(define edn->rtag
|
|
(edn->atom (lambda (result pile input)
|
|
(char=? #\# (peek-char input)))
|
|
(lambda (result pile input)
|
|
(or (is-whitespace? (peek-char input))
|
|
(char=? #\( (peek-char input))
|
|
(char=? #\[ (peek-char input))
|
|
(and (not (null? pile))
|
|
(char=? #\{ (car pile)))))
|
|
(lambda (in) (cons edn/tag: (string->keyword (list->string in))))))
|
|
|
|
(define edn->coll
|
|
(case-lambda
|
|
((ld rd finalize) (lambda (subparser input) (edn->coll subparser ld rd finalize '() input #t)))
|
|
((subparser ld rd finalize result input fresh?)
|
|
(cond
|
|
;; End of sequence
|
|
((or (eq? #!eof (peek-char input))
|
|
(char=? rd (peek-char input)))
|
|
(cons (finalize (reverse result)) (begin (read-char input) input)))
|
|
;; First character of sequence
|
|
((and (char=? ld (peek-char input))
|
|
fresh?)
|
|
(edn->coll subparser ld rd finalize result (begin (read-char input) input) #f))
|
|
;; Sub-sequence of same type
|
|
((char=? ld (peek-char input))
|
|
(let ((sub-result (subparser input)))
|
|
(edn->coll subparser ld rd finalize (cons (cadr sub-result) result) (caddr sub-result) #f)))
|
|
;; Stuff in the data!
|
|
(else (let ((compiled (subparser input)))
|
|
(edn->coll (first compiled)
|
|
ld rd finalize
|
|
(if (equal? (second compiled) edn/omit:)
|
|
result
|
|
(cons (second compiled) result))
|
|
(third compiled) #f)))))))
|
|
|
|
(define edn->list (edn->coll #\( #\) (lambda (x) x)))
|
|
(define edn->vector (edn->coll #\[ #\] (lambda (x) (list->vector x))))
|
|
|
|
(define edn->htable
|
|
(case-lambda
|
|
((subparser input) (edn->htable subparser (make-hash-table) '() input #t))
|
|
((subparser result key input fresh?)
|
|
(cond ((or (eq? #!eof (peek-char input))
|
|
(char=? #\} (peek-char input)))
|
|
(cons result (begin (read-char input) input)))
|
|
((and (char=? #\{ (peek-char input))
|
|
fresh?)
|
|
(edn->htable subparser result key (begin (read-char input) input) #f))
|
|
(else (let ((compiled (subparser input)))
|
|
(cond
|
|
((eq? edn/omit: (second compiled))
|
|
(edn->htable (first compiled) result key (third compiled) #f))
|
|
((null? key)
|
|
(edn->htable (first compiled) result (second compiled) (third compiled) #f))
|
|
(else
|
|
(edn->htable (first compiled) (begin (hash-table-set! result key (second compiled)) result)
|
|
'() (third compiled) #f)))))))))
|
|
|
|
(define (edn->whitespace subparser input)
|
|
(if (char-whitespace? (peek-char input))
|
|
(cons edn/omit: (begin (read-char input) input))
|
|
(cons (read-char input) input)))
|
|
|
|
(define (guard-charcheck fun)
|
|
(lambda (x)
|
|
(and (char? x)
|
|
(fun x))))
|
|
|
|
@(heading "Reading EDN")
|
|
|
|
(define tag-handlers @("An a-list containing the handlers for reader tags. You can register your own reader tags by simply adding a new a-list entry.
|
|
|
|
Example for a tag \"#keywordify\": add the entry `(cons keywordify: keywordify-procedure)`.")
|
|
(list (cons _: (lambda (input) edn/omit:))))
|
|
|
|
(define reader-handlers
|
|
(list (cons (is-char? #\() edn->list)
|
|
(cons (is-char? #\)) edn->list)
|
|
(cons (is-char? #\[) edn->vector)
|
|
(cons (is-char? #\]) edn->vector)
|
|
(cons (is-char? #\{) edn->htable)
|
|
(cons (is-char? #\}) edn->htable)
|
|
(cons (is-char? #\#) edn->rtag)
|
|
(cons (is-char? #\:) edn->keyword)
|
|
(cons (is-char? #\") edn->string)
|
|
(cons (guard-charcheck is-symbolstarter?) edn->symbol)
|
|
(cons (guard-charcheck is-number?) edn->number)
|
|
(cons (guard-charcheck is-whitespace?) edn->whitespace)))
|
|
|
|
(define (is-tag? in)
|
|
(and (pair? in)
|
|
(pair? (car in))
|
|
(equal? (caar in) edn/tag:)
|
|
(contains-tag-handler? (car in))))
|
|
|
|
(define (contains-tag-handler? tag)
|
|
(assoc (cdr tag) tag-handlers))
|
|
|
|
(define (call-tag tag data)
|
|
((cdr (assoc (cdr tag) tag-handlers)) data))
|
|
|
|
(define (parse-edn state)
|
|
(lambda (in-port)
|
|
(let* ((struct-handler (cdr
|
|
(find (lambda (item) ((car item) (peek-char in-port)))
|
|
reader-handlers)))
|
|
(result (struct-handler (parse-edn state) in-port)))
|
|
(list (if (is-tag? result)
|
|
(parse-edn result)
|
|
(parse-edn '()))
|
|
(cond ((is-tag? state)
|
|
(call-tag (car state) (car result)))
|
|
((is-tag? result)
|
|
edn/omit:)
|
|
(else (car result)))
|
|
(cdr result)))))
|
|
|
|
(define (read-edn port)
|
|
@("Reads EDN data from given port, converts it to Chicken data and returns it. Precision suffixes for numbers get ignored, maps get converted to SRFI-69 hashtables, vectors to SRFI-4 vectors.")
|
|
(second ((parse-edn '()) port)))
|
|
|
|
;; EDN writing
|
|
;; ===========
|
|
|
|
(define (pair->reader-tag subparser in)
|
|
(string-append "#" (keyword->string (cdr in))))
|
|
|
|
(define (scm-kw->edn-kw subparser in)
|
|
(string-append ":" (keyword->string in)))
|
|
|
|
(define (boolean->edn subparser in)
|
|
(case in
|
|
((#t) "true")
|
|
((#f) "false")
|
|
(else "nil")))
|
|
|
|
(define (char->edn subparser in)
|
|
(string #\\ in))
|
|
|
|
(define (string->edn subparser in)
|
|
(string-append "\"" in "\""))
|
|
|
|
(define (number->edn subparser in)
|
|
(number->string in))
|
|
|
|
(define (sequential->edn subparser ld rd in)
|
|
(string-append ld
|
|
(fold-right (lambda (elem init)
|
|
(string-append (subparser elem)
|
|
(if (equal? "" init) "" " ")
|
|
init))
|
|
"" in)
|
|
rd))
|
|
|
|
(define (list->edn subparser in)
|
|
(sequential->edn subparser "(" ")" in))
|
|
|
|
(define (vector->edn subparser in)
|
|
(sequential->edn subparser "[" "]" (vector->list in)))
|
|
|
|
(define (map->edn subparser in)
|
|
(string-append "{"
|
|
(fold-right (lambda (elem init)
|
|
(string-append (subparser (car elem))
|
|
" "
|
|
(subparser (cdr elem))
|
|
(if (equal? "" init) "" " ")
|
|
init))
|
|
"" in)
|
|
"}"))
|
|
|
|
(define (htable->edn subparser in)
|
|
(string-append "{"
|
|
(hash-table-fold in
|
|
(lambda (hkey hval folded)
|
|
(string-append (subparser hkey)
|
|
" "
|
|
(subparser hval)
|
|
(if (equal? "" folded) "" " ")
|
|
folded))
|
|
"")
|
|
"}"))
|
|
|
|
(define (nil->edn subparser in)
|
|
"nil")
|
|
|
|
(define (symbol->edn subparser in)
|
|
(symbol->string in))
|
|
|
|
(define (edn-readertag? in)
|
|
(and
|
|
(not (list? in))
|
|
(pair? in)
|
|
(equal? edn/reader-tag: (car in))))
|
|
|
|
(define (edn-alist? in)
|
|
(and (list? in)
|
|
(any (lambda (item) (and (not (list? item)) (pair? item)))
|
|
in)))
|
|
|
|
(define (edn-htable? in)
|
|
(hash-table? in))
|
|
|
|
(define writer-handlers
|
|
(list (cons null? nil->edn)
|
|
(cons string? string->edn)
|
|
(cons char? char->edn)
|
|
(cons boolean? boolean->edn)
|
|
(cons number? number->edn)
|
|
(cons keyword? scm-kw->edn-kw)
|
|
(cons symbol? symbol->edn)
|
|
(cons vector? vector->edn)
|
|
(cons edn-alist? map->edn)
|
|
(cons edn-htable? htable->edn)
|
|
(cons edn-readertag? pair->reader-tag)
|
|
(cons list? list->edn)))
|
|
|
|
(define (parse-entry in)
|
|
((cdr
|
|
(find (lambda (item) ((car item) in))
|
|
writer-handlers))
|
|
parse-entry in))
|
|
|
|
@(heading "Writing EDN")
|
|
|
|
(define (write-edn port struct)
|
|
@("Converts Chicken data structures to EDN and writes it to the given port."
|
|
(struct "A Chicken data structure consisting of atoms, lists, vectors and hashtables."))
|
|
(display (parse-entry struct) port))
|