;;;; coops-introspection.scm
;;;; Kon Lovett, Jul '17
;;;; Kon Lovett, Aug '10

;; Issues
;;
;; - all slot options are "lost" after definition.
;;
;; - generic-procedure introspection is dicey since the generic
;; has no "entity" representation & methods are not 1st-class.

(module coops-introspection

(;export
  ;tiny-clos work-alike
  class-cpl class-supers  ;= class-precedence-list
  primitive?              ;= primitive-instance?
  generic-methods         ;= generic-primary-methods
  ;
  instance-of?
  class? check-class error-class
  instance? check-instance error-instance
  generic? check-generic error-generic
  method? check-method error-method
  primitive-instance?
  ;
  class-precedence-list class-direct-supers
  class-slots class-direct-slots
  ;
  generic-anonymous?
  generic-name
  generic-specialized-arguments
  generic-primary-methods
  generic-before-methods
  generic-after-methods
  generic-around-methods
  ;
  method-specializers
  method-procedure)

(import scheme)

(import chicken)

(import (only srfi-1 every fold-right lset-difference lset-union))
(require-library srfi-1)

(import (only type-checks define-check+error-type))
(require-library type-checks)

(require-extension coops)

;;; Helpers

(define (union-class-prop-vals getter classes)
  (fold-right
    (lambda (class ls)
      (lset-union eq? ls (getter class)) )
    '()
    classes) )

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

(define (*class-supers class)
  (slot-value class 'class-precedence-list) )

(define (union-class-slots classes)
  (union-class-prop-vals *class-slots classes) )

(define (union-class-supers classes)
  (union-class-prop-vals *class-supers classes) )

(define (class-supers-slots class)
  (union-class-slots (*class-supers class)) )

(define (class-supers-supers class)
  (union-class-supers (*class-supers class)) )

;c1 < c2
(define (strict-subclass? c1 c2)
  (subclass? c1 c2) )

;c1 <= c2
(define (loose-subclass? c1 c2)
  (or
    (eq? c1 c2)
    (strict-subclass? c1 c2)) )

(define (*method-specializers method)
  (car method) )

(define (*method-procedure method)
  (cdr method) )

(define (error-generic-form loc obj idx)
  (error loc "generic closure form violation" obj idx) )

(define (check-generic-form loc obj0 idx type-pred?)
  (let ((obj (##sys#slot (check-generic loc obj0) idx)))
    (unless (type-pred? obj)
      (error-generic-form loc obj0 idx) )
    obj ) )

(define (check-generic-methods loc obj idx)
  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )

(define (top-instance-of? x class)
  (let ((class-x (class-of x)))
    (or
      (eq? #t class-x) ;primitive
      (loose-subclass? class class-x) ) ) )

;; call-by-ref

(define (generic-name? obj)
  (or
    (not obj)
    (symbol? obj)) )

(define (vector-boxed-list? obj)
  (and
    (vector? obj)
    (= 1 (vector-length obj))
    (list? (vector-ref obj 0))) )

;;; Predicates

(define (instance-of? x class)
  (loose-subclass? (class-of x) class) )

(define (class? x)
  (instance-of? x <standard-class>) )

(define (instance? x)
  (not (top-instance-of? x <standard-class>)) )

(define (primitive-instance? x)
  (top-instance-of? x <primitive-object>) )

(define (method? obj)
  (and
    (pair? obj)
    (procedure? (*method-procedure obj))
    (let ((specializers (*method-specializers obj)))
      (and
        (list? specializers)
        (every class? specializers) ) ) ) )

;;; Errors & Checks

(define-check+error-type class class? "coops-class")
(define-check+error-type instance instance? "coops-instance")
(define-check+error-type generic generic-procedure? "coops-generic")
(define-check+error-type method method? "coops-method")

;;; Introspection

;; Class Properties

(define (class-precedence-list class)
  (*class-supers (check-class 'class-precedence-list class)) )

(define (class-slots class)
  (*class-slots (check-class 'class-slots class)) )

;; Class Direct Properties

;those supers declared in the direct class & not inherited
(define (class-direct-supers class)
  (check-class 'class-direct-supers class)
  (lset-difference eq? (*class-supers class) (class-supers-supers class)))

;those slots declared in the direct class & not inherited
(define (class-direct-slots class)
  (check-class 'class-direct-slots class)
  (lset-difference eq? (*class-slots class) (class-supers-slots class)) )

;; Generic Properties

(define (generic-anonymous? generic)
  (and
    (generic-procedure? generic)
    (not (##sys#slot generic 1)) ) )

(define (generic-name generic)
  (check-generic-form 'generic-name generic 1 generic-name?) )

(define (generic-specialized-arguments generic)
  (check-generic-form 'generic-specialized-args generic 7 pair?) )

(define (generic-primary-methods generic)
  (check-generic-methods 'generic-primary-methods generic 2) )

(define (generic-before-methods generic)
  (check-generic-methods 'generic-before-methods generic 3) )

(define (generic-after-methods generic)
  (check-generic-methods 'generic-after-methods generic 4) )

(define (generic-around-methods generic)
  (check-generic-methods 'generic-around-methods generic 5) )

;; Method Properties

(define (method-specializers method)
  (check-method 'method-specializers method)
  (*method-specializers method) )

(define (method-procedure method)
  (check-method 'method-procedure method)
  (*method-procedure method) )

;;; Synonyms

(define class-cpl class-precedence-list)
(define class-supers class-precedence-list)

(define primitive? primitive-instance?)

(define generic? generic-procedure?)

(define generic-methods generic-primary-methods)

) ;coops-introspection