(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 *obj-acons*
  (make-parameter
   (lambda (key value rest)
     (acons (string->symbol key) value rest))))

(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)))
      '()
      (let ([key (parse-value (car ss))]
	    [value (parse-value (cadr ss))]
	    [rest (parse-object (cddr ss))])
	((*obj-acons*) key value rest))))

(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 #:key obj-acons)
  "Parses a json string into a sexp"
  (define match (match-pattern value string))
  (if match
      (if obj-acons
	  (parameterize ([*obj-acons* obj-acons])
	    (parse-value (peg:tree match)))
	  (parse-value (peg:tree match)))
      (raise-exception (make-exception
			(make-external-error)
			(make-exception-with-irritants string)))))