Add json parser

d-/json.scm

@@ -0,0 +1,78 @@
+(define-module (d- json)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 peg)
+  #:export (json))
+
+(define-peg-pattern ++       none (* (or "\t" "\n" "\r" " ")))
+(define-peg-pattern comma    none (and "," ++))
+(define-peg-pattern open-sq  none (and "[" ++))
+(define-peg-pattern close-sq none (and "]" ++))
+(define-peg-pattern open-cu  none (and "{" ++))
+(define-peg-pattern close-cu none (and "}" ++))
+(define-peg-pattern boolean  all  (and (or "true" "false")
+				       ++))
+(define-peg-pattern number   all  (and (or (and (+ (range #\0 #\9)) "." (* (range #\0 #\9)))
+					   (and (?".") (+ (range #\0 #\9))))
+				       ++))
+(define-peg-pattern string   all  (and (ignore "\"")
+				       (* (or "\\\""
+					      (and (not-followed-by "\"") peg-any)))
+				       (ignore "\"") ++))
+(define-peg-pattern earr     all  (and open-sq close-sq))
+(define-peg-pattern array    all  (or earr
+				      (and open-sq
+					   (* (and value comma))
+					   value
+					   close-sq)))
+(define-peg-pattern eobj     all  (and open-cu close-cu))
+(define-peg-pattern object   all  (or eobj
+				      (and open-cu
+					   (* (and string (ignore ":") ++ value comma))
+					   (and string (ignore ":") ++ value)
+					   close-cu)))
+(define-peg-pattern value    body (or number boolean string array object))
+
+(define (parse-boolean s)
+  (if (string= s "true") #t #f))
+
+(define (parse-number s)
+  (string->number s))
+
+(define (parse-string s)
+  s)
+
+(define (parse-array ss)
+  (if (symbol? (car ss))
+      '()
+      (map parse-value ss)))
+
+(define (parse-object ss)
+  (if (or (null? ss) (null? (cdr ss)))
+      '()
+      (acons (string->symbol (parse-value (car ss)))
+	     (parse-value (cadr ss))
+	     (parse-object (cddr ss)))))
+
+(define flatwords '(boolean number string array object))
+
+(define (parse-value s)
+  (if (pair? s)
+      (case (car s)
+	[(boolean) (parse-boolean (cadr s))]
+	[(number)  (parse-number  (cadr s))]
+	[(string)  (parse-string  (cadr s))]
+	[(array)   (parse-array   (keyword-flatten flatwords (cdr s)))]
+	[(object)  (parse-object  (keyword-flatten flatwords (cdr s)))])
+      (raise-exception
+       (make-exception
+	(make-programming-error)
+	(make-exception-with-irritants s)))))
+
+(define (json string)
+  "Parses a json string into a sexp"
+  (define match (match-pattern value string))
+  (if match 
+      (parse-value (peg:tree match))
+      (raise-exception (make-exception
+			(make-external-error)
+			(make-exception-with-irritants string)))))

test.scm

@@ -1,5 +1,6 @@
 (use-modules (d-)
 	     (d- test)
+	     (d- json)
 	     (srfi srfi-1))
 
 (define-test-suite "~>"
@@ -100,3 +101,28 @@
 	(amb-require (or (= mary  4) (= betty 1)))
 	(list betty ethel joan kitty mary)))
     (assert-equal '(3 5 2 1 4) (liars))))
+
+(define-test-suite "json"
+  (define-test "boolean"
+    (assert-equal #t (json "true"))
+    (assert-equal #f (json "false")))
+  (define-test "number"
+    (assert-equal 1.1 (json "1.1"))
+    (assert-equal 0.1 (json ".1"))
+    (assert-equal 1.0 (json "1.")))
+  (define-test "string"
+    (assert-equal "hello" (json "\"hello\""))
+    (assert-equal "\\\"hello\\\"" (json "\"\\\"hello\\\"\"")))
+  (define-test "array"
+    (assert-equal '() (json "[]"))
+    (assert-equal '(1 "two" #f) (json "[1, \"two\", false]"))
+    (assert-equal '(() (())) (json "[[], [[]]]")))
+  (define-test "object"
+    (assert-equal '() (json "{}"))
+    (assert-equal '((cat . 1)
+		    (bat . #t)
+		    (rat . "yessir"))
+		  (json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\"}"))
+    (assert-equal '((butter . 1)
+		    (brownie))
+		  (json "{\"butter\": 1, \"brownie\": {}}"))))