;;;; coops-extras.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett, Aug '10

(module coops-extras

(;export
  slot@
  make-copy)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (srfi 1) list-copy cons* remove))
(import (only coops-introspection check-instance))
(import coops)

;;;

(define-type coops-class *)
(define-type coops-instance *)

(define-type plist list)

;;;coops-introspection

(: *class-slots (coops-class -> list))
;
(define (*class-slots class)
  (slot-value class 'slots) )

;;; Helpers

;;

;memq is not specific enough
(: plist-key? (symbol plist -> boolean))
;
(define (plist-key? key ls)
  ;search plist for key name
  (let adv ((ls ls))
    (and
      (not (null? ls))
      (or
        (eq? key (car ls))
        (adv (cddr ls)) ) ) ) )

(: plist-cons (symbol * plist -> plist))
;
(define (plist-cons key val ls)
  (cons* key val ls) )

;;

;memq is not specific enough
(: initslot? (symbol list -> boolean))
;
(define (initslot? slot initforms)
  (plist-key? slot initforms) )

(: slot-values (coops-instance (list-of symbol) #!optional list -> list))
;
(define (slot-values obj slots #!optional (base '()))
  (foldl
    (lambda (ls slot)
      (if (slot-initialized? obj slot)  ;per Jun 19, '17 email from Sandra Snan
        (plist-cons slot (slot-value obj slot) ls)
        ls ) )
    base
    slots) )

(: shadowed-initforms (coops-instance list #!optional coops-class -> list))
;
(define (shadowed-initforms obj initforms #!optional (class (class-of obj)))
  ;shallow copy of the slots - share values but not storage
  ;FIXME 1-pass, dup storage & replace new values
  (slot-values
    obj
    (remove (cut initslot? <> initforms) (list-copy (*class-slots class)))
    initforms) )

;;; Extras

;;

;sub-instance slot reference
(define-syntax slot@
  (syntax-rules (=)
    ;
    ((slot@ ?obj)
      ?obj )
    ;
    ((slot@ ?obj ?slot = ?valu)
      (set! (slot-value ?obj '?slot) ?valu) )
    ;
    ((slot@ ?obj ?slot ?rest0 ...)
      (slot@ (slot-value ?obj '?slot) ?rest0 ...) ) ) )

;;

;use w/ <primitive-object> is very suspect
(: make-copy (coops-instance #!rest -> *))
;
(define (make-copy obj . initforms)
  (let ((class (class-of (check-instance 'make-copy obj))))
    (apply make class (shadowed-initforms obj initforms class)) ) )

) ;coops-extras