In the beginning there was darkness

.gitignore

@@ -0,0 +1,2 @@
+*~
+*.c

LICENSE

@@ -0,0 +1,23 @@
+Copyright (c) 2013, Daniel Ziltener
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
+
+  Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+  Redistributions in binary form must reproduce the above copyright notice, this
+  list of conditions and the following disclaimer in the documentation and/or
+  other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1,51 @@
+[![License](//img.shields.io/badge/license-BSD-blue.svg?style=flat)]()
+[![Boot](//img.shields.io/badge/Chicken-Scheme-ECC42F.svg?style=flat)](http://www.call-cc.org/) 
+[![Clojars](//img.shields.io/badge/Eggversion-0.5.1-blue.svg?style=flat)](http://wiki.call-cc.org/eggref/4/edn)
+[![Gratipay](//img.shields.io/gratipay/zilti.svg?style=flat)](//gratipay.com/zilti)
+[![Flattr this](//api.flattr.com/button/flattr-badge-small.png)](https://flattr.com/submit/auto?user_id=zilti&url=https%3A%2F%2Fbitbucket.org%2Fzilti%2Fedn)
+
+chicken-edn
+===========
+
+An [EDN](https://github.com/edn-format/edn) reader and writer for chicken scheme.
+
+Installation: `chicken-install edn`
+
+Data type conversions
+---------------------
+
+ * All kinds of numbers get converted to Scheme numbers, precision suffixes (N and M) get ignored.
+ * Keywords :keyword get converted to chicken scheme keywords keyword:.
+ * Maps get converted to SRFI 69 hashtables.
+ * Vectors are srfi-4 vectors.
+ * true = #t, false = #f, nil = '()
+
+Missing reader functionality
+----------------------------
+Should you notice missing functionality of the reader, plesase use [the issues page](https://bitbucket.org/zilti/edn/issues?status=new&status=open) to report
+it and, if possible, provide a minimal test case.
+
+API
+---
+
+* Transforming EDN into Chicken: `(with-input-from-port <port> read-edn)`
+* Transforming Chicken into EDN: `(with-output-to-port <port> (write-edn <datastructure>))`
+* Using reader tags: the library contains a public a-list `tag-handlers`. To register a handler, add an a-list entry where the key is the tag without `\#` and as a keyword, and the value a one-argument procedure.
+
+Releases
+--------
+
+ * **0.5.1**: Small compatibility improvements: "/" now starts a symbol as well, and "," is treated as whitespace.
+ * **0.5**: Reader tag support.
+ * **0.4**: Complete rewrite. Only relies on R7RS, and SRFI 1, 4, 69 and 88. Uses ports. Reads and writes EDN.
+ * **0.3**: EDN tags, including special forms, work. #inst and #uuid both get read as strings. Add nil. Add number prefixes. Add no-space-required to #_ tag.
+ * **0.2.1**: Can read EDN-files and -strings. EDN tags are not working yet.
+ * **0.2**: Can read EDN-strings with one top-level data structure.
+
+Roadmap
+-------
+
+
+About
+-----
+Written by Daniel Ziltener. EDN written by Rich Hickey. The EDN specification is available at [https://github.com/edn-format/edn](https://github.com/edn-format/edn).

edn-impl.scm

@@ -0,0 +1,322 @@
+(import scheme
+	srfi-69
+	srfi-1
+	(chicken keyword)
+	(chicken port))
+;; 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))))

edn.egg

@@ -0,0 +1,11 @@
+;;; -*- scheme -*-
+
+((author "Daniel Ziltener")
+ (synopsis "EDN data reader/writer.")
+ (category parsing)
+ (license "BSD")
+ (dependencies hahn srfi-69 srfi-1)
+ (test-dependencies srfi-64)
+ (components (extension edn
+			(modules edn)
+			(csc-options "-X" "hahn"))))

edn.scm

@@ -0,0 +1,10 @@
+@(heading "EDN")
+
+@(text "This egg provides a parser and a writer for the [[https://github.com/edn-format/edn|Extensible Data Notation]].")
+
+@(heading "Documentation")
+@(noop)
+
+(use srfi-1 srfi-69 srfi-88)
+(module edn (parse-entry tag-handlers write-edn read-edn)
+  "edn-impl.scm")

tests/run.scm

@@ -0,0 +1,52 @@
+(require-extension r7rs srfi-69 srfi-64 srfi-88 srfi-1 hahn)
+(include "../edn-impl.scm")
+;; (run-hahn -o edn.wiki edn.scm edn-impl.scm)
+
+(define s->k string->keyword)
+
+(test-begin "EDN writing")
+
+(test-equal (parse-entry keyword:) ":keyword")
+(test-equal (parse-entry #t) "true")
+(test-equal (parse-entry #f) "false")
+(test-equal (parse-entry '()) "nil")
+(test-equal (parse-entry #\a) "\\a")
+(test-equal (parse-entry "String") "\"String\"")
+(test-equal (parse-entry (cons edn/reader-tag: neat:)) "#neat")
+
+
+(test-equal (list->edn parse-entry '(1 2 3 4)) "(1 2 3 4)")
+(test-equal (vector->edn parse-entry #(a: b: c: d:)) "[:a :b :c :d]")
+(test-equal (parse-entry '((a: . "Hi")
+		      (b: . i-am:)
+		      (c: . (a list)))) "{:a \"Hi\" :b :i-am :c (a list)}")
+(test-end "EDN writing")
+
+(test-begin "EDN reading")
+(define wifs with-input-from-string)
+
+(test-equal (wifs "(:keyword)" read-edn)  '(keyword:))
+(test-equal (wifs "(123)" read-edn) '(123))
+(test-equal (wifs "(\"Hello World!\")" read-edn) '("Hello World!"))
+(test-equal (wifs "(false)" read-edn) '(#f))
+(test-equal (wifs "(true)" read-edn) '(#t))
+(test-equal (wifs "(:Hello \"World\" 1)" read-edn) '(Hello: "World" 1))
+(test-equal (wifs "[:a :b :c :d]" read-edn) #(a: b: c: d:))
+(test-assert 
+  ((lambda (a b)
+     (and (equal? (hash-table-ref b a:) "Hi")
+	  (equal? (hash-table-ref b b:) i-am:)
+	  (equal? (hash-table-ref b c:) `(a list))))
+   (alist->hash-table '((a: . "Hi") (b: . i-am:) (c: . (a list))))
+   (wifs "{:a \"Hi\" :b :i-am :c (a list)}" read-edn)))
+(test-end "EDN reading")
+
+(test-begin "Tag handling")
+(test-equal (wifs "(1 2 #_ 3 4)" read-edn) '(1 2 4))
+
+(set! tag-handlers (cons (cons keywordify:
+			       (lambda (input)
+				 (string->keyword (symbol->string input))))
+			 tag-handlers))
+(test-equal (wifs "(asdf #keywordify qwertz)" read-edn) '(asdf qwertz:))
+(test-end "Tag handling")