;;;; jso -- JavaScript objects
;;; Copyright 2010 John Cowan
;;; BSD-style license: http://synthcode.com/license.txt

;;; This library allows the creation and use of JavaScript-style objects
;;; (JSOs), which are chained association lists that map symbol keys
;;; to arbitrary values.  JSOs can be searched with 'assq' as well as
;;; with 'jso-ref'.

;;; When you create a JSO, you can specify a prototype JSO which will
;;; be searched along with its own prototype (etc.)  if your JSO doesn't
;;; contain a particular key.  Modifications, however, are only applied
;;; to the referenced JSO, not to anything along the prototype chain.
;;; An attempt to look up an unknown key returns a unique value which
;;; can be tested with 'jso-undef?'.

;;; In addition to key-value pairs, a JSO also has an associated special
;;; value, which is the undefined value by default but can be changed
;;; to be any Scheme object.

;; The car of the first entry in a JSO must be the flag object.
(define flag (string-copy "jso"))

;; This is the undefined value returned if lookup fails.
(define undef (string-copy "undef"))

;; Returns true if its argument is a JSO.
(define (jso? obj)
  (and (pair? obj) (pair? (car obj)) (eq? (caar obj) flag)))

;; Returns true if its argument is the undefined value.
(define (jso-undef? obj) (eq? obj undef))

;; Throws an error if its argument is not a JSO, otherwise returns it.
(define (check-jso obj) (if (jso? obj) obj (error "Not a JSO")))

;; Retrieves the value for the given JSO and key, or undef if not found.
(define (jso-ref jso key)
  (let ((kv (assq key (check-jso jso))))
    (if kv (cdr kv) undef)))

;; Constructs a new JSO.  If an argument is supplied, it must be a JSO
;; and is used as the prototype for the new object.
(define (make-jso . maybe-proto)
  (if (null? maybe-proto)
      (list (cons flag undef))
      (cons (cons flag undef) (check-jso (car maybe-proto)))))

;; Throws an error if its argument is not a valid key, otherwise returns it.
(define (check-key obj)
  (if (symbol? obj) obj (error "Not a valid JSO key")))

;; Sets a new value into a JSO; the proto chain is not searched.
(define (jso-set! jso key value)
  (let loop ((kv (cdr (check-jso jso))))
    (cond
      ;; end of JSO
      ((null? kv) (jso-add! jso key value))
      ;; proto reached
      ((jso? kv) (jso-add! jso key value))
      ;; match found
      ((eq? key (caar kv)) (set-cdr! (car kv) value))
      ;; or keep looping
      (else (loop (cdr kv))))))

;; Forcibly adds a new key-value pair to a JSO (unsafe).
(define (jso-add! jso key value)
  (let ((rest (cdr jso)))
    (set-cdr! jso (cons (cons (check-key key) value) rest))))

;; Removes a key from a JSO; the proto chain is not searched.
;; Therefore, if the same key exists in the proto chain, it will
;; be exposed.  Attempts to remove nonexistent keys are ignored.
(define (jso-remove! jso key)
  (let loop ((kv (cdr (check-jso jso)))
             (prev jso))
    (cond
      ;; end of JSO, nothing to do
      ((null? kv) (if #f #f))
      ;; proto reached, nothing to do
      ((null? kv) (if #f #f))
      ;; match found
      ((eq? key (caar kv))
        (set-cdr! prev (cdr kv)))
      ;; or keep looping
      (else (loop (cdr kv) (cdr prev))))))

;; Returns a shallow copy of the JSO that shares the same prototype.
(define (jso-copy jso)
  (let loop ((kv (cdr (check-jso jso)))
             (result '()))
    (cond
      ;; end of JSO
      ((null? kv) (cons (cons flag undef) (reverse result)))
      ;; proto reached
      ((jso? kv) (append (cons (cons flag undef) (reverse result)) kv))
      ;; or apply proc and keep looping
      (else (loop (cdr kv)
         (let ((key (caar kv)) (value (cdar kv)))
           (cons (cons key value) result)))))))

;; Returns a shallow copy of the JSO including the whole prototype chain.
;; The old and the new JSOs share nothing.
(define (jso-full-copy jso)
  (let loop ((lis jso))			
    (if (pair? lis)				
	(cons (cons (caar lis) (cdar lis)) (loop (cdr lis)))
        lis)))

;; Applies the procedure (method) which is the value of the given key to the
;; JSO.  Any trailing arguments are also passed.

(define (jso-apply jso key . args) (apply (jso-ref jso key) jso args))

;; Applies the procedure (method) which is the value of the given key
;; to the JSO.  Any trailing arguments are also passed.  If there is
;; no such key, the fallback procedure is invoked instead.
(define (jso-apply/fallback jso key fallback . args)
  (let* ((value (jso-ref jso key))
         (proc (if (jso-undef? value) fallback value)))
    (apply proc jso args)))

;; Returns the JSO's special value.
(define (jso-value jso) (cdar (check-jso jso)))

;; Sets the JSO's special value.
(define (jso-set-value! jso value)
  (set-cdr! (car (check-jso jso)) value))

;; Returns the JSO's proto, or undef if it has none.
(define (jso-proto jso)
  (let loop ((kv (cdr (check-jso jso))))
    (cond
      ;; end of JSO
      ((null? kv) undef)
      ;; proto reached, return it
      ((jso? kv) kv)
      ;; or keep looping
      (else (loop (cdr kv))))))

;;; Mappers.  These all accept procedures which take two arguments,
;;; the key and the value respectively, and return the new value.

;; Returns a new JSO after applying the mapping function to each
;; key-value pair of the old JSO.  The new and old JSOs share protos.
(define (jso-map proc jso)
  (let loop ((kv (cdr (check-jso jso)))
             (result '()))
    (cond
      ;; end of JSO
      ((null? kv) (cons (cons flag undef) (reverse result)))
      ;; proto reached
      ((jso? kv) (append (cons (cons flag undef) (reverse result)) kv))
      ;; or apply proc and keep looping
      (else (loop (cdr kv)
         (let ((key (caar kv)) (value (cdar kv)))
           (cons (cons key (proc key value)) result)))))))

;; Modifies an existing JSO using the mapping function.  The proto
;; chain is left undisturbed.
(define (jso-map! proc jso)
  (let loop ((kv (cdr (check-jso jso))))
    (cond
      ;; end of JSO
      ((null? kv) (if #f #f))
      ;; proto reached
      ((jso? kv) (if #f #f))
      ;; or apply proc and keep looping
      (else (let ((key (caar kv)) (value (cdar kv)))
               (set-cdr! (car kv) (proc key value))
               (loop (cdr kv)))))))

;; Executes a procedure over all the key-value pairs of a JSO.
;; The prototype chain is not processed.
(define (jso-for-each proc jso)
  (let loop ((kv (cdr (check-jso jso))))
    (cond
      ;; end of JSO
      ((null? kv) (if #f #f))
      ;; proto reached
      ((jso? kv) (if #f #f))
      ;; or apply proc and keep looping
      (else (let ((key (caar kv)) (value (cdar kv)))
               (proc key value)
               (loop (cdr kv)))))))

;; Returns a new JSO after applying the mapping function to each
;; key-value pair of the old JSO including the whole prototype chain.
;; The new and old JSOs share nothing.
(define (jso-full-map proc jso)
  (define (mapper kv)
    (let ((key (car kv))
          (value (cdr kv)))
      (if (eq? key flag)
        (cons key (proc key value))
        (cons key value))))
  (map mapper jso))

;; Note that there is no jso-full-map!, on the principle that no JSO
;; procedure makes a destructive change to the proto chain.

;; Executes a procedure over all the key-value pairs of a JSO,
;; including the full prototype chain.
(define (jso-full-for-each proc jso)
  (define (mapper kv)
    (let ((key (car kv))
          (value (cdr kv)))
      (if (eq? key flag)
          #f
          (proc key value))))
  (for-each mapper jso))