;;
;; 
;;  A parser for JavaScript Object Notation (JSON) 
;;
;;  Based on RFC 4627, "The application/json Media Type for JavaScript
;;  Object Notation (JSON)" 
;;
;;
;;   Copyright 2009-2010 Ivan Raikov and the Okinawa Institute of
;;   Science and Technology.
;;
;;
;;   This program is free software: you can redistribute it and/or
;;   modify it under the terms of the GNU General Public License as
;;   published by the Free Software Foundation, either version 3 of
;;   the License, or (at your option) any later version.
;;
;;   This program is distributed in the hope that it will be useful,
;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   General Public License for more details.
;;
;;   A full copy of the GPL license can be found at
;;   <http://www.gnu.org/licenses/>.


(module json-abnf

	(parser)

	(import scheme chicken data-structures srfi-1 srfi-14)

	(require-library abnf-charlist abnf-consumers)
	(import (prefix abnf-charlist abnf:) 
		(prefix abnf-consumers abnf:) 
		)


;; helper macro for mutually-recursive parser definitions

(define-syntax vac
  (syntax-rules ()
    ((_ fn) (lambda args (apply fn args)))))

;; construct numbers from consumed chars
(define consumed-chars->number
  (abnf:consumed-chars->list 
   (compose string->number list->string)))

;; shortcut for (bind consumed-chars->number (longest ... ))
(define-syntax bind-consumed->number
  (syntax-rules () 
    ((_ p)    (abnf:bind
	       consumed-chars->number
	       (abnf:longest p)))
    ))

(define consumed-chars->char-code
  (abnf:consumed-chars->list 
   (compose (lambda (x) (string->number x 16))
	    list->string)))

(define-syntax bind-consumed->char-code
  (syntax-rules () 
    ((_ p)    (abnf:bind
	       consumed-chars->char-code
	       (abnf:longest p)))
    ))

(define (value?  x)    (or (string? x) (number? x) (boolean? x)
			   (vector? x) (list? x)))

(define consumed-values (abnf:consumed-objects value?))
(define consumed-values->list (abnf:consumed-objects-lift consumed-values))

;; shortcut for (abnf:bind (consumed-values->list ...) (abnf:longest ... ))
(define-syntax bind-consumed-values->list
  (syntax-rules () 
    ((_ l p)    (abnf:bind (consumed-values->list l)  (abnf:longest p)))
    ((_ p)      (abnf:bind (consumed-values->list)    (abnf:longest p)))
    ))

;; construct vectors from consumed values
(define consumed-values->vector 
  ((abnf:consumed-objects-lift consumed-values)
   list->vector))

;; shortcut for (abnf:bind (consumed-values->vector ...) (abnf:longest ... ))
(define-syntax bind-consumed-values->vector
  (syntax-rules () 
    ((_ p)      (abnf:bind consumed-values->vector  (abnf:longest p)))
    ))

(define ws (abnf:repetition (abnf:set-from-string " \t\r\n")))

(define (structural-char c)
  (abnf:drop-consumed
   (abnf:concatenation
    ws (abnf:char c) ws
    )))

(define begin-array     (structural-char #\[))
(define begin-object    (structural-char #\{))
(define end-array       (structural-char #\]))
(define end-object      (structural-char #\}))
(define name-separator  (structural-char #\:)) 
(define value-separator (structural-char #\,)) 

(define value 
  (vac
   (abnf:alternatives 
    false null true number p-string  object array)))

(define false
  (abnf:bind
   (abnf:consumed-chars->list (lambda x #f))
   (abnf:lit "false")))

(define null
  (abnf:bind
   (abnf:consumed-chars->list (lambda x '()))
   (abnf:lit "null")))

(define true
  (abnf:bind
   (abnf:consumed-chars->list (lambda x (list #t)))
   (abnf:lit "true")))

(define escaped 
  (abnf:concatenation
   (abnf:drop-consumed (abnf:char #\\))
   (abnf:alternatives
    (abnf:set 
     (char-set #\" #\\ #\/ #\backspace #\page 
	       #\newline #\return #\tab))
    (bind-consumed->char-code
     (abnf:repetition-n 4 abnf:hexadecimal)))))

     
(define char
  (abnf:alternatives
   (abnf:set 
    (char-set-union
      (ucs-range->char-set #x20 #x21)
      (ucs-range->char-set #x23 #x5B)
      (ucs-range->char-set #x5D #x10FFFF)))
   escaped))

(define p-string
  (abnf:bind-consumed->string
   (abnf:concatenation
    (abnf:drop-consumed (abnf:char #\"))
    (abnf:repetition char)
    (abnf:drop-consumed (abnf:char #\")))))


(define number
  (let* ((digit        (abnf:range #\0 #\9))
	 (digits       (abnf:repetition1 digit))
	 (fraction     (abnf:concatenation (abnf:char #\.) digits))
	 (significand  (abnf:alternatives 
			(abnf:concatenation 
			 digits
			 (abnf:optional-sequence fraction)) 
			fraction))
	 (exp          (abnf:concatenation
			(abnf:set-from-string "eE") 
			(abnf:concatenation
			 (abnf:optional-sequence 
			  (abnf:set-from-string "+-"))
			 digits)))
	 (sign         (abnf:optional-sequence 
			(abnf:char #\-))))

    (bind-consumed->number
     (abnf:concatenation 
      sign
      (abnf:concatenation 
       significand
       (abnf:optional-sequence exp))))))


(define p-member 
  (bind-consumed-values->list
   (abnf:concatenation
    p-string
    name-separator 
    value
    )))


(define object
  (abnf:bind-consumed-pairs->list 'object
   (abnf:concatenation
    begin-object
    (abnf:optional-sequence
     (abnf:concatenation
      p-member 
      (abnf:repetition
       (abnf:concatenation 
	value-separator 
	p-member))))
    end-object)))



  
(define array
  (bind-consumed-values->vector
   (abnf:concatenation
    begin-array
    (abnf:optional-sequence
     (abnf:concatenation
      value
      (abnf:repetition
       (abnf:concatenation
	value-separator
	value ) )))
    end-array))
  )


(define JSON-text
  (abnf:alternatives object array))


(define (->char-list s)
  (if (string? s) (string->list s) s))


(define (err s)
  (print "JSON parser error on stream: " s)
  (list))


(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))


(define parser
  (let ((p (abnf:longest JSON-text)))
    (lambda (s)
      (reverse (caar (p (check s) `((() ,(->char-list s)))))))))

)