;; 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) @("Reads EDN data from the `current-input-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 '()) (current-input-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 (foldr (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 "{" (foldr (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 struct) @("Converts Chicken data structures to EDN and writes it to the `current-output-port`." (struct "A Chicken data structure consisting of atoms, lists, vectors and hashtables.")) (lambda () (display (parse-entry struct) (current-output-port))))