;;;; 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)

(: make-copy (coops-instance #!rest -> *))

(: *class-slots (coops-class --> list))
(: plist-key? (symbol plist --> boolean))
(: plist-cons (symbol * plist --> plist))
(: initslot? (symbol list --> boolean))
(: only-origforms (coops-class list --> list))
(: slot-values (coops-instance (list-of symbol) #!optional list --> list))
(: shadowed-initforms (coops-instance list #!optional coops-class --> list))

;;;coops-introspection

(define (*class-slots class) (slot-value class 'slots))

;;; Helpers

;;

;memq is not specific enough
(define-inline (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)) ) ) ) )

(define-inline (plist-cons key val ls) (cons* key val ls))

;;

;memq is not specific enough
(define-inline (initslot? slot initforms) (plist-key? slot initforms))

(define-inline (only-origforms class initforms)
  (remove (cut initslot? <> initforms) (list-copy (*class-slots class))) )

(define-inline (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) )

(define-inline (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 (only-origforms class initforms) 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 ...) ) ) )

;;

(define-generic (make-copy obj))

(define-method (make-copy (obj #t) . initforms)
  (let ((class (class-of obj)))
    (if (eq? class #t)
        ;then obj used thru a coops interface
        (error 'make-copy "cannot copy coops instance of class `#t'" obj)
        ;else an instance
        (apply make class (shadowed-initforms obj initforms class)) ) ) )

) ;coops-extras