;;;; coops-introspection.scm
;;;; 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
    ;
    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
    chicken
    (only srfi-1 every fold-right lset-union! lset-difference)
    (only type-checks define-check+error-type)
    coops)

  (require-library
    srfi-1
    type-checks coops)

;;; Helpers

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

(define-inline (union-class-slots classes)
  (fold-right
    (lambda (class ls) (lset-union! eq? ls (*class-slots class)))
    '()
    classes) )

(define-inline (union-class-supers classes)
  (fold-right
    (lambda (class ls) (lset-union! eq? ls (*class-supers class)))
    '()
    classes) )

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

(define-inline (*subclass? c1 c2) (or (eq? c1 c2) (subclass? c1 c2)))

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

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

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

(define-inline (check-generic-form loc obj0 idx pred)
  (check-generic loc obj0)
  (let ((obj (##sys#slot obj0 idx)))
    (unless (pred obj)
      (error-generic-form 'generic-specialized-args obj0 idx) )
    obj ) )

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

;;; Predicates

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

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

(define (instance? x)
  (let ((class-x (class-of x)))
    (not (or (eq? class-x #t) ; unknown primitive is not considered an instance
             (*subclass? class-x <standard-class>))) ) )

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

(define (method? obj)
  (and (pair? obj)
       (let ((specializers (car obj)))
         (and (list? specializers)
              (every class? specializers)))
       (procedure? (cdr obj))) )

;;; 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)
  (check-class 'class-precedence-list class)
  (*class-supers class) )

(define (class-slots class)
  (check-class 'class-slots 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)) )

;;

#; ;Bad, Bad, Bad
(define (print-closure p)
  (##sys#check-closure p 'print-closure)
  (print "0\t: #x" (number->string (##sys#peek-unsigned-integer p 0) 16))
  (let ((size (##sys#size p)))
    (do ((i 1 (add1 i)))
        ((= i size))
      (print i "\t: " (##sys#slot p i)) ) ) )

;; Generic Properties

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

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

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

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

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

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

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

;; Method Properties

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

(define (method-procedure method)
  (check-method 'method-procedure method)
  (cdr 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