;;;; json-utils.scm -*- Scheme -*-
;;;; Kon Lovett, Sep '21
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett, Jul '13

;; Issues
;;
;; - Use of (void) as undefined.
;;
;; - JSON w/ vector as Array & alist/hash-table as Dictionary
;;
;; - Use of vector for JSON Array is problematic since JS assumes Array is Sparse.
;;
;; - HOF are 1-ary, like srfi-69

#|
  - maker(integer | symbol | string ,
          count | initial-count | void ,
          default-value)
    tester
    getter setter
    folder (unfolder?)
    [counter - (folder count-elms 0 json)] [mampper] [eacher]
    ... formatter | converters ...
    [reader] [writer]

    - No `delete'

    - `count' => fixed-size & `initial-count' => variable-size

    - vector is fixed & sparse-vector is variable
|#

(module json-utils

(;export
  ;
  json-undefined
  json-keyform
  ;
  json-undefined?
  json-keyform?
  ;
  json-array? json-object? json-collection?
  json-count
  json-ref
  ;
  json-fold json-map json-for-each
  json-foldl)

(import scheme utf8
  (chicken base)
  (chicken type)
  (srfi 1)
  (srfi 69)
  vector-lib
  miscmacros
  moremacros)

(define-type alist (list-of pair))

(define-type json-array vector)
(define-type json-object (or alist hash-table))
(define-type json-collection (or json-array json-object))
(define-type json-object-key (or string symbol))
(define-type json-key (or json-object-key fixnum))
;(define-type json-unknown (not boolean))

;(: json-undefined (#!optional (or boolean json-unknown) -> json-unknown))
(: json-undefined (#!optional * -> *))
(: json-keyform (#!optional symbol -> symbol))

(: json-undefined? (* -> boolean))
(: json-keyform? (* -> boolean : json-object-key))

(: json-array? (* -> boolean : json-array))
(: json-object? (* -> boolean : json-object))
(: json-collection? (* -> boolean : json-collection))

(: json-count (json-collection -> fixnum))
(: json-ref (json-collection #!rest -> *))

(: json-fold (json-collection (json-key * * -> *) * -> *))
(: json-map (json-collection (json-key * -> *) -> (list-of *)))
(: json-for-each (json-collection (json-key * -> *) -> void))

(: json-foldl (json-collection ('a json-key * -> 'a) 'a -> 'a))

;;

(define (alist? x)
  (and (list? x)
       #; ;minimal check
       (every pair? x))
       (or (null? x) (pair? (car x))) )

;;;

;; Undefined Value

(define JSON-UNDEFINED (void))

;since any can be undef no test
(define-parameter json-undefined JSON-UNDEFINED)

(define (json-undefined? x) (eq? x (json-undefined)))

;; Keyform

(define-constant JSON-KEYFORM 'symbol)

(define (json-keyform? x)
  (case x
    ((symbol string) x)
    (else #f)) )

(define-warning-parameter json-keyform JSON-KEYFORM json-keyform)

(define (keyform-eql #!optional (keyform (json-keyform)))
  (case keyform
    ((symbol) eq?)
    ((string) string=?) ) )

(define (symbol->keyform key #!optional (keyform (json-keyform)))
  (case keyform
    ((symbol) key)
    ((string) (symbol->string key)) ) )

(define (string->keyform key #!optional (keyform (json-keyform)))
  (case keyform
    ((symbol) (string->symbol key))
    ((string) key) ) )

(define (array-key->vector-index loc key)
        ;FIXME real memory index must fit in a fixnum but could change representation
  (cond ((fixnum? key) key)
        ((integer? key) (array-key->vector-index loc (inexact->exact key)))
        ((string? key) (array-key->vector-index loc (string->number key)))
        ((symbol? key) (array-key->vector-index loc (symbol->string key)))
        ((or (ratnum? key) (flonum? key)) (array-key->vector-index loc (floor key)))
        (else
          (error loc "invalid keyform for array" key) ) ) )

;;

(define (json-key loc key #!optional (keyform (json-keyform)))
  (cond ((symbol? key) (symbol->keyform key keyform))
        ((string? key) (string->keyform key keyform))
        (else
          (error loc "invalid keyform for dictionary" key) ) ) )

(define (valid-vector-ref? json idx)
  (and (fixnum? idx) (not (negative? idx)) (< idx (vector-length json))) )

;;

(define (json-array? x) (vector? x))
(define (json-object? x) (or (alist? x) (hash-table? x)))

;;

(define (json-dictionary-count loc json)
  (if (list? json) (length json)
      (hash-table-size json)) )

(define (json-array-count loc json) (vector-length json))

;;

(define (json-dictionary-ref loc json key keyform undef)
  (let ((key (json-key loc key keyform)))
    (if (list? json) (alist-ref key json (keyform-eql keyform) undef)
        (hash-table-ref/default json key undef)) ) )

(define (json-array-ref loc json key keyform undef)
  (let ((idx (array-key->vector-index loc key)))
    (if (not (valid-vector-ref? json idx)) undef
        (vector-ref json idx) ) ) )

(define (*json-ref loc json key keyform undef)
  (cond ((json-array? json)
          (json-array-ref loc json key keyform undef))
        ((json-object? json)
          (json-dictionary-ref loc json key keyform undef))
        (else
          (error loc "invalid json object" json))) )

;;

(define (check-alist-element loc obj)
  ;minimal check
  (unless (pair? obj)
    (error loc "not an alist element" obj))
  obj )

(define ((json-alist-element-callback loc func) cell . args)
  (check-alist-element loc cell)
  (apply func (car cell) (cdr cell) args))

(define (json-dictionary-fold loc json func init)
  (if (list? json)
      (fold (json-alist-element-callback loc func) init json)
      (hash-table-fold json (lambda (k v acc) (func k v acc)) init)) )

(define (json-dictionary-map loc json func)
  (if (list? json)
      (map (json-alist-element-callback loc func) json)
      (hash-table-map json func)) )

(define (json-dictionary-for-each loc json func)
  (if (list? json)
      (for-each (json-alist-element-callback loc func) json)
      (hash-table-for-each json func)) )

(define (json-dictionary-foldl loc json func init)
  (json-dictionary-fold loc json (lambda (i elm acc) (func acc i elm)) init) )

(define (json-array-fold loc json func init)
  (vector-fold (lambda (i acc elm) (func i elm acc)) init json) )

(define (json-array-map loc json func)
  (vector-fold (lambda (i ls elm) (cons (func i elm) ls)) '() json) )

(define (json-array-for-each loc json func)
  (vector-for-each (lambda (i elm) (func i elm)) json) )

(define (json-array-foldl loc json func init)
  (json-array-fold loc json (lambda (i elm acc) (func acc i elm)) init) )

;;

(define (json-collection? x) (or (json-array? x) (json-object? x)))

(define (json-count json)
  (cond ((json-array? json)
          (json-array-count 'json-count json))
        ((json-object? json)
          (json-dictionary-count 'json-count json))
        (else
          (error 'json-count "invalid json object" json))) )

(define (json-ref json key . args)
  (let ((undef (json-undefined)) (keyform (json-keyform)))
    (let loop ((json (*json-ref 'json-ref json key keyform undef)) (keys args))
      (if (null? keys) json
          (loop (*json-ref 'json-ref json (car keys) keyform undef) (cdr keys)) ) ) ) )

;;

(define (json-fold json func init)
  (cond ((json-array? json)
          (json-array-fold 'json-fold json func init))
        ((json-object? json)
          (json-dictionary-fold 'json-fold json func init))
        (else
          (error 'json-fold "invalid json object" json))) )

(define (json-map json func)
  (cond ((json-array? json)
          (json-array-map 'json-map json func))
        ((json-object? json)
          (json-dictionary-map 'json-map json func))
        (else
          (error 'json-map "invalid json object" json))) )

(define (json-for-each json func)
  (cond ((json-array? json)
          (json-array-for-each 'json-for-each json func))
        ((json-object? json)
          (json-dictionary-for-each 'json-for-each json func))
        (else
          (error 'json-for-each "invalid json object" json))) )

;foldl (acc k/i ... elm ...) seed seq ...
;
(define (json-foldl json func init)
  (cond ((json-array? json)
          (json-array-foldl 'json-foldl json func init))
        ((json-object? json)
          (json-dictionary-foldl 'json-foldl json func init))
        (else
          (error 'json-foldl "invalid json object" json))) )

;;; JSON support

#;
(define json-find-with-memo
  ;a      => (a)
  ;(a)    => (a)
  ;a ...  => (a ...)
  (define (ensure-param-list args)
    (cond ((null? args) '())
          ((null? (cdr args)) (ensure-list (car args)))
          (else args) ) )
  (let ((ht (make-hash-table eq?)))
    (lambda (json . args)
      (let ((keys (ensure-param-list args)))
        ;
        (define (newval vht)
          (let ((res (apply json-find json keys)))
            (hash-table-set! vht keys res)
            res ) )
        ;
        (let ((vht (hash-table-ref/default ht json #f)))
          (if vht
              (if (hash-table-exists? vht indicies)
                  (hash-table-ref vht indicies)
                  (newval vht) )
              (let ((vht (make-hash-table equal?)))
                (hash-table-set! ht json vht)
                (newval vht) ) ) ) ) ) ) )

;; Pretty-print JSON to specified port.

#;
(define (json-pp object #!optional (port #t))
  ;
  (define (find-every object pad level)
    (cond ((list? object)
            (let loop ((n 0))
              (when (< n (length object))
                (let ((i (list-ref object n)))
                  (find-every i pad (+ 1 level))
                  (when (< n (- (length object) 1))
                    (newline) )
                  (loop (+ 1 n))))) )
          ((vector? object)
            (vector-for-each
              (lambda (idx alist)
                (let ((key (car alist)) (value (cdr alist)))
                  (cond ((vector? value)
                          (format port "~a~a: (~a)~%" (pad level) key (vector-length value))
                          (find-every value pad (+ 1 level)))
                        ((list? value)
                          (format port "~a~a: (~a)~%" (pad level) key (length value))
                          (find-every value pad (+ 1 level)))
                        (else
                          (format port "~a~a: ~a~%" (pad level) key value))) ) )
              object)) ) )
  ;
  (find-every object (lambda (n) (make-string (* 2 n) #\space)) 0) )

;; Locate a property, e.g., "businesses.neighborhood.name".

#;
(define (json-find table thing)
  ;
  (define (find-object object thing root)
    (call/cc
      (lambda (return)
        (cond ((list? object)
                (for-each
                  (lambda (i)
                    (let ((r (find-object i thing root)))
                      (when r
                        (return r) ) ) )
                  object) )
              ((vector? object)
                (vector-for-each
                  (lambda (idx alist)
                    (let ((key (car alist)) (value (cdr alist)))
                      ;;(format #t "find: thing: ~a vs. ~a~%" thing (string-append root "." key))
                      (when (and (string=? thing (string-append root "." key))
                                 (or (not (string? value))
                                     (and (string? value) (not (string=? value "")))))
                        (return value) ) )
                    (cond
                      ((vector? value)
                        (let ((r (find-object value thing (string-append root "." key))))
                          (and r (return r))))
                      ((list? value)
                        (if (> (length value) 0)
                            (let loop ((i 0))
                              (let ((r (find-object (list-ref value i) thing (string-append root "." key))))
                                (and r (return r)))
                              (if (< i (- (length value) 1))
                                  (loop (+ i 1)))))))))
                object ) )
      #f ) ) )
  ;
  (find-object table (string-append "." thing) "") )

) ;json-utils