;;;; coops-introspection.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; 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.
;;
;; - should use more "schemey" names for operations?

(module coops-introspection

(;export
  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 base))
(import (chicken type))
(import (only (srfi 1) every lset-difference lset-union))
(import (only type-checks-basic define-check+error-type))
(import coops)

(include-relative "coops.types")

(define-type error-location (or false symbol))
;(define-type error-object *) ;d'uh
(define-type error-argument (or false symbol string))

(: instance-of? (* coops-class -> boolean))
(: class? (* -> boolean : coops-class))
(: instance? (* -> boolean : coops-instance))
(: primitive-instance? (* -> boolean))
(: generic? (* -> boolean))
(: method? (* -> boolean))

(: check-class (error-location * #!optional error-argument -> coops-class))
(: error-class (error-location * #!optional error-argument -> void))
(: check-instance (error-location * #!optional error-argument -> coops-instance))
(: error-instance (error-location * #!optional error-argument -> void))
(: check-generic (error-location * #!optional error-argument -> coops-generic))
(: error-generic (error-location * #!optional error-argument -> void))
(: check-method (error-location * #!optional error-argument -> coops-method))
(: error-method (error-location * #!optional error-argument -> void))

(: class-precedence-list (coops-class -> (list-of coops-class)))
(: class-slots (coops-class -> (list-of symbol)))
(: class-direct-supers (coops-class -> (list-of coops-class)))
(: class-direct-slots (coops-class -> (list-of symbol)))

(: generic-anonymous? (* -> boolean : coops-generic))
(: generic-name (coops-generic -> symbol))
(: generic-specialized-arguments (coops-generic -> (list-of symbol)))
(: generic-primary-methods (coops-generic -> (list-of coops-method)))
(: generic-before-methods (coops-generic -> (list-of coops-method)))
(: generic-after-methods (coops-generic -> (list-of coops-method)))
(: generic-around-methods (coops-generic -> (list-of coops-method)))

(: method-specializers (coops-method -> (list-of coops-class)))
(: method-procedure (coops-method -> procedure))

;;; Helpers

(: union-class-property-values ((coops-class -> 'a) (list-of coops-class) -> (list-of 'a)))

(: *class-slots (coops-class -> (list-of symbol)))
(: *class-supers (coops-class -> (list-of coops-class)))

(: union-class-slots ((list-of coops-class) -> (list-of (list-of symbol))))
(: union-class-supers ((list-of coops-class) -> (list-of (list-of coops-class))))

(: class-supers-slots (coops-class -> (list-of (list-of symbol))))
(: class-supers-supers (coops-class -> (list-of (list-of coops-class))))

(: *method-specializers (pair -> *))
(: *method-procedure (pair -> *))

(: error-generic-form (symbol * fixnum -> void))
(: check-generic-form (symbol * fixnum procedure -> *))
(: checked-generic-methods (symbol * fixnum -> *))

(: coops-instance? (* -> boolean))
(: parent-instance? (* coops-class -> boolean))
(: generic-name? (* -> boolean))
(: vector-boxed-list? (* -> boolean))

(define (union-class-property-values getter classes)
  (foldr (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-property-values *class-slots classes))
(define (union-class-supers classes) (union-class-property-values *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)))

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

(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 (checked-generic-methods loc obj idx)
  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )

(define (coops-instance? x)
  (import (chicken memory representation))
  (record-instance? x coops-instance) )

; class << class(x)
(define (parent-instance? x class)
  (let ((class-x (class-of x)))
    (and (not (eq? class-x class))
         (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) (subclass? (class-of x) class))

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

(define (instance? x)
  (and (coops-instance? x)
       (not (class? x))) )

(define (primitive-instance? x)
  (let ((class-x (class-of x)))
    (or (eq? #t class-x)
        (subclass? class-x <primitive-object>)) ) )

;FIXME for results of `generic-*-methods' ONLY!
(define (method? obj)
  (and (pair? obj)
       (procedure? (*method-procedure obj))
       (and-let* ((specializers (*method-specializers obj))
                  ((list? specializers)) )
        (every class? specializers) ) ) )

;;; Errors & Checks

(define generic? generic-procedure?)

(define-check+error-type class class? "coops-class")
(define-check+error-type instance instance? "coops-instance")
(define-check+error-type generic generic? "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? 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)
  (checked-generic-methods 'generic-primary-methods generic 2) )

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

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

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

;; Method Properties

(define (method-specializers method)
  (let ((ms (*method-specializers (check-method 'method-specializers method))))
    (unless (list? ms)
      (error 'method-specializers "not a list" ms) )
    ms ) )

(define (method-procedure method)
  (let ((mp (*method-procedure (check-method 'method-procedure method))))
    (unless (procedure? mp)
      (error 'method-procedure "not a procedure" mp) )
    mp ) )

) ;coops-introspection