;;;; coops-utils test  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(import test)

(import (only (chicken format) format) (test-utils gloss))

(import (chicken syntax))
(import (srfi 1))
(import (srfi 13))
(import coops)

;;;

(test-begin "Coops Utils")

(import coops-utils)

;

(test-group "predicates"
  (test-assert (class? <standard-class>))
  (test-assert (not (instance? <standard-class>)))
  (test-assert (not (primitive-instance? <standard-class>)))
  (test-assert (not (method? <standard-class>)))
  (test-assert (not (generic? <standard-class>)))

  (test-assert (not (class? 23)))
  (test-assert (not (instance? 23)))
  (test-assert (primitive-instance? 23))
  (test-assert (not (method? 23)))
  (test-assert (not (generic? 23)))

  (test-assert (not (class? +)))
  (test-assert (not (instance? +)))
  (test-assert (primitive-instance? +))
  (test-assert (not (generic? +)))
  (test-assert (not (method? +)))
)

;; setup test reference environment

(define-class <s1xy> () ((x 's1xy-x) (y 's1xy-y)))
(define-class <s1ab> () ((a 's1ab-a) (b 's1ab-b)))
(define-class <s2xz> () ((x 's2xz-x) (z 's2xz-z)))
(define-class <s2ac> () ((a 's2ac-a) (c 's2ac-c)))

(define-class <s1xys1ab> (<s1xy> <s1ab>)
  ((x 's1xys1ab-x) (y 's1xys1ab-y) (a 's1xys1ab-a) (b 's1xys1ab-b) (me '<s1xys1ab>)))
(define-class <s2xzs2ac> (<s2xz> <s2ac>)
  ((x 's2xzs2ac-x) (z 's2xzs2ac-z) (a 's2xzs2ac-a) (c 's2xzs2ac-c)))

(define-class <s1xys2xz> (<s1xy> <s2xz>) ())
(define-class <s2xzs1ab> (<s2xz> <s1ab>) ())

(define-generic (foo abc xyz))

(define-method (foo primary: (abc <s1xy>) (xyz <s1ab>)) 'primary-<s1xy><s1ab>)
(define-method (foo before: (abc <s1xy>) (xyz <s1ab>)) 'before-<s1xy><s1ab>)
(define-method (foo after: (abc <s1xy>) (xyz <s1ab>)) 'after-<s1xy><s1ab>)
(define-method (foo around: (abc <s1xy>) (xyz <s1ab>)) 'around-<s1xy><s1ab>)

(define-method (foo primary: (abc <s2xz>) (xyz <s2ac>)) 'primary-<s2xz><s2ac>)
(define-method (foo before: (abc <s2xz>) (xyz <s2ac>)) 'before-<s2xz><s2ac>)
(define-method (foo after: (abc <s2xz>) (xyz <s2ac>)) 'after-<s2xz><s2ac>)
(define-method (foo around: (abc <s2xz>) (xyz <s2ac>)) 'around-<s2xz><s2ac>)

(test-group "introspection"
  (test (list <s2xz> <standard-object> <s1ab>) (class-precedence-list <s2xzs1ab>))
  (test '(x z a b) (class-slots <s2xzs1ab>))

  (test-assert (class? <s2xzs2ac>))
  (test (list <standard-object>) (class-direct-supers <s2ac>))
  (test '(a c) (class-direct-slots <s2ac>))

  (test-assert (class? <s1xys1ab>))
  (test (list <s1xy> <s1ab>) (class-direct-supers <s1xys1ab>))
  (test '(me) (class-direct-slots <s1xys1ab>))

  (test 'foo (generic-name foo))
  (test '(abc xyz) (generic-specialized-arguments foo))
  (test-assert (eq? 2 (length (generic-primary-methods foo))))
  (let ((primaries (generic-primary-methods foo)))
    (for-each
      (lambda (x)
        (test-assert (method? x))
        (test-assert (procedure? (method-procedure x)))
        (let ((specials (method-specializers x)))
          (test-assert (list? specials))
          (test-assert (every class? specials)) ) )
      primaries) )
)

(define-class <first> () (next))
(define-class <second> (<first>) ())
(define-class <third> (<second>) ())

(define 1st (make <first> 'next (make <second> 'next (make <third> 'next "the end"))))

(test-group "slot@"
  (test "the end" (slot@ 1st next next next))
  (slot@ 1st next next next = "still the end")
  (test "still the end" (slot@ 1st next next next))
)

(define s1xy-inst (make <s1xy> 'x 1 'y 2))
(test-group "simple instance"
  (test-assert (instance? s1xy-inst))
  (test-assert (instance-of? s1xy-inst <s1xy>))
  ;(describe-object s1xy-inst)
)

(test-group "make-copy instance"
  (test-error "cannot copy primitive object" (make-copy '()))
  (test-assert "coops-instance copy" (make-copy s1xy-inst 'y 23))
  (test-error "no such slot for initform" (make-copy s1xy-inst 'foo 23))
  (let ((inst (make-copy s1xy-inst 'y 23)))
    ;check copy
    (test-assert "made copy is an instance" (instance? inst))
    (test-assert "made copy is correct instance" (instance-of? inst <s1xy>))
    (test "made copy has overridden slot" 23 (slot@ inst y))
    (test "made copy has original slot" 1 (slot@ inst x))
    ;copy own slots?
    (slot@ inst x = 32)
    (test "made copy has slot assign" 32 (slot@ inst x))
    (test "source has slot original" 1 (slot@ s1xy-inst x)) )
)

(test-group "primitive-instance"
  (import coops-primitive-objects)

  (test-assert "can copy primitive object (after import)" (make-copy '()))
  (let ((inst (make-copy '())))
    ;check copy
    (test-assert "made copy is an instance" (instance? inst))
    (test-assert "made copy is correct instance" (instance-of? inst <null>)) )
)

(test-group "generic"
  (define-generic (city-market-class obj))
  (define-generic (city-goods obj))
  (define-class city () (name (market-class reader: city-market-class) sellers buyers (goods accessor: city-goods)))
  (define temphawa (make city 'name "Hawa" 'market-class 2))
  (test-assert "make-copy temphawa" (make-copy temphawa))
)

;

(test-end "Coops Utils")

;;

(test-begin "Coops Describe")

(import coops-describe)

(test-group "Coops Describe"
  (test-assert (generic? describe-object))

  (glossln)
  (gloss "(describe-object <third>)")
  (describe-object <third>)

  (glossln)
  (gloss "(describe-object s1xy-inst)")
  (describe-object s1xy-inst)

  (glossln)
  (gloss "(describe-object describe-object)")
  (describe-object describe-object)

  (glossln)
  (gloss "(print-closure describe-object)")
  (print-closure describe-object)
)

(test-end "Coops Describe")

;;

(test-begin "Coops Introspection")

(import coops-introspection)

(generic-name describe-object)

(test-end "Coops Introspection")

;;;

(test-exit)

;---

#|
;; Named (has a name) "concept"

(define-generic (name obj))
(define-class <named> () (
  (namsym #:reader name) ) )

;; Moves foreward thru a set of values "concept"

(define-generic (step-function obj))
(define-class <stepper> () (
  (nxtval #:reader step-function) ) )
(define-generic (next-value obj))
(define-method (next-value (obj <stepper>)) ((step-function obj)))

;; Parameterized extension "concept"

(define-generic (parameters obj))
(define-generic (basis obj))
(define-class <parameterized> () (
  (parms #:reader parameters)
  (src #:reader basis) ) )

;; Parameterized generative set of random values "concept"

(define-class <random-distribution> (<named> <parameterized> <stepper>) (
  temp ) )

;; Create an instance of <random-distribution> where the arguments are
;; the same as the documented procedural distribution API.
;;
;; SRFI 27 API: ({some distribution constructor} arg...)
;;      OO API: (make-random-distribution {some distribution constructor} arg...)

(define-syntax make-random-distribution
  (syntax-rules ()
    ((_ ?ctor ?arg0 ...)
      (make <random-distribution> 'temp (?ctor ?arg0 ...)) ) ) )

(define-method (initialize-instance (obj <random-distribution>))
  ;Reconstruct distribution api ctor invocation parameters
  ;(The 'ctor' must be a globally defined procedure compiled
  ;with procedure-information. So if following nomenclature then the last
  ;procedure name element will be the kind of distribution.)
  (let* ((temp (slot@ obj temp))
         (ctor (car temp))
         (procinfo (procedure-information ctor))
         (name (and (pair? procinfo) (symbol->string (car procinfo))))
         (name (and-let* ((name)
                          (kndpos (string-index-right name #\-)) )
                 (substring/shared name (+ kndpos 1)) ) )
         (dstr-vals (receive (apply ctor (cdr temp))))
         (parms (and (<= 2 (length dstr-vals)) (receive ((second dstr-vals))))) )
    (slot@ obj temp = #f) ;"free" the "any" slot
    (slot@ obj namsym = (string->symbol name))
    (slot@ obj nxtval = (first dstr-vals))
    (slot@ obj parms = (and parms (drop-right parms 1))) ) )
|#