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

(include-relative "coops.types")

(: make-copy (coops-instance #!rest -> *)) ;coop-primitive-instance is `*'

;;;

(define-type slotname (or symbol keyword))
(define-type slotnames (list-of slotname))

;coops-introspection

(: *class-slots (coops-class -> slotnames))

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

;;; Helpers

(define-type plist list)

(: plist-key? (slotname plist -> boolean))
(: plist-cons (slotname * plist -> plist))

(: initslot? (slotname list -> boolean))
(: only-origforms (coops-class plist -> slotnames))
(: slot-values (coops-instance slotnames #!optional slotnames -> plist))
(: shadowed-initforms (coops-instance list #!optional coops-class -> plist))

;;

;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? #t class)
        ;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