(define-library (zambyte meta json)
  ;; portable
  (export json
	  define-json-record-type
	  json-ref
	  json-value?

	  json-record-from-string-allow-missing-keys
	  json-key-not-found)
  ;; non-portable
  (export json-object
	  json-list
	  json-null

	  json-object?
	  json-list?
	  json-null?
	  json-object-contains-key?

	  string->json
	  json->string

	  json-object-ref
	  json-object-set!
	  json-list-ref
	  json-list-length

	  json-object-map
	  json-list-map

	  json-object->alist
	  json-list->list)
  (import (scheme base))
  (cond-expand
   (gerbil (import (std srfi 1)
		   (only (gerbil core) and-let*)))
   (else (import (srfi 1)
		 (srfi 2))))
  ;; portable
  (begin
    (define-syntax json
      (syntax-rules (object list null true false)
	((_ (object (key . value) ...))
	 (json-object `(key . ,(json value)) ...))
	((_ (list vs ...))
	 (json-list (json vs) ...))
	((_ null) json-null)
	((_ true) #t)
	((_ false) #f)
	((_ value)
	 (if (json-value? value)
	     value
	     (error "json: not a json value" value)))))

    (define-syntax define-json-record-type
      (syntax-rules ()
	((_ type
	    (constructor fields ...)
	    from-json-string
	    predicate
	    field-declarations ...)
	 (begin
	   (define-values (constructor predicate from-json-string)
	     ((lambda ()
		(define-record-type type
		  (internal-json-record fields ...)
		  internal-json-record?
		  field-declarations ...)

		(define-syntax accessors
		  (syntax-rules ::: ()
		    ((_) '())
		    ((_ (name accessor . optional-mutator) rest :::)
		     (cons `(name . ,accessor) (accessors rest :::)))))

		(define-syntax mutators
		  (syntax-rules ::: ()
		    ((_) '())
		    ((_ (name accessor) rest :::)
		     (mutators rest :::))
		    ((_ (name accessor mutator) rest :::)
		     (cons `(name . ,mutator) (mutators rest :::)))))

		(define (constructor fields ...)
		  (define (typeless)
		    (json-object `(fields . ,fields) ...))
		  (json-record (internal-json-record fields ...)
			       'type
			       typeless
			       (accessors field-declarations ...)
			       (mutators field-declarations ...)))

		(define (predicate obj)
		  (cond
		   ((json-record? obj) (internal-json-record?
					(json-record->internal-record obj)))
		   ((json-object? obj) (and (json-object-contains-key? obj 'fields) ...))
		   (else #f)))

		(define (from-json-string str)
		  (let ((json (string->json str)))
		    (if (json-record-from-string-allow-missing-keys)
			;; Assume that json-key-not-found is set to something sensible
			(constructor (json-object-ref json 'fields) ...)
			(parameterize ((json-key-not-found
					(lambda ()
					  (error "key not found in json string when converting to a record" 'type))))
			  (constructor (json-object-ref json 'fields) ...)))))
		(values constructor predicate from-json-string))))
	   (define-syntax define-accessors-and-mutators
	     (syntax-rules ::: ()
	       ((_) (values))
	       ((_ (name accessor) rest :::)
		(begin
		  (define (accessor json)
		    (if (json-record? json)
			(or (and-let* ((pair (assoc 'name (json-record->accessors json)))
				       (acc (cdr pair)))
			      (acc (json-record->internal-record json)))
			    (error (string-append (symbol->string 'accessor) ": no accessor for field") (json-record->name json) 'name))
			(json-object-ref json 'name)))
		  (define-accessors-and-mutators rest :::)))
	       ((_ (name accessor mutator) rest :::)
		(begin
		  (define (accessor json)
		    (if (json-record? json)
			(or (and-let* ((pair (assoc 'name (json-record->accessors json)))
				       (acc (cdr pair)))
			      (acc (json-record->internal-record json)))
			    (error (string-append (symbol->string 'accessor) ": no accessor for field") (json-record->name json) 'name))
			(json-object-ref json 'name)))
		  (define (mutator json value)
		    (if (json-record? json)
			(or (and-let* ((pair (assoc 'name (json-record->mutators json)))
				       (mut! (cdr pair)))
			      (mut! (json-record->internal-record json) value)
			      json)
			    (error (string-append (symbol->string 'mutator) ": no mutator for field") (json-record->name json) 'name))
			(json-object-set! json 'name value)))
		  (define-accessors-and-mutators rest :::)))))
	   (define-accessors-and-mutators field-declarations ...)))))

    (define-record-type <json-record>
      (json-record internal-record name typeless accessors mutators)
      json-record?
      (internal-record json-record->internal-record)
      (name json-record->name)
      (typeless json-record->typeless)
      (accessors json-record->accessors)
      (mutators json-record->mutators))

    (define json-record-from-string-allow-missing-keys (make-parameter #f))

    (define (json->typeless-json json)
      (cond
       ((json-record? json)
	(json->typeless-json ((json-record->typeless json))))
       ((json-object? json)
	(json-object-map (lambda (k v) (values k (json->typeless-json v))) json))
       ((json-list? json)
	(json-list-map (lambda (v) (json->typeless-json v)) json))
       (else json)))

    (define (json-ref json key . keys)
      (let ((ref (cond ((json-object? json) json-object-ref)
		       ((json-list? json) json-list-ref)
		       (else (error "json-ref: cannot get reference on json value" json)))))
	(if (null? keys)
	    (ref json key)
	    (apply json-ref (ref json key) keys))))

    (define (json-value? obj)
      (or (boolean? obj)
	  (number? obj)
	  (string? obj)
	  (json-null? obj)
	  (json-list? obj)
	  (json-object? obj)))

    (define json-key-not-found (make-parameter (lambda () (values)))))
  ;; non-portable
  (cond-expand
   ((and (library (macduffie json)) (library (srfi 69)))
    (include-library-declarations "macduffie.scm"))
   ((and guile (library (json)))
    (import (only (guile) include-from-path import))
    (begin (include-from-path "zambyte/meta/guile-json.scm")))
   (gauche
    (include-library-declarations "gauche.scm"))
   (gerbil
    (include-library-declarations "gerbil.scm"))
   (sagittarius
    (include-library-declarations "sagittarius.scm"))
   ((library (chibi json))
    (include-library-declarations "chibi.scm"))
   ((library (srfi 180))
    (include-library-declarations "180.scm"))
   (else
    (error "No implementation of JSON library available."))))