(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (member :closer-mop *features*)
    (ql:quickload "closer-mop")))

(defpackage "SILEX.TESTS.MIGRATION"
  (:use "COMMON-LISP")
  (:export "REPORT-INTERNALS-DIVERGENCE"))
(in-package "SILEX.TESTS.MIGRATION")

;;; The migration incorporates a step where we separate SILEX-INTERNALS and
;;; CLIM-INTERNALS, while all symbols previously lived in the latter package.
;;; This, among other things, introduces the following risks that are not
;;; reported by the compiler:
;;;
;;; 1. duplicated generic functions with different sets of methods
;;; 2. same slot names are not now collapsed into a single effective slot
;;; 
;;; Note that after these migration tests pass SILEX-INTERNALS and CLIM-INTERNAL
;;; may diverge all they want, because they will be separate.

(defun collect-package-symbols (package)
  (let (result)
    (do-symbols (symbol package result)
      (push symbol result))))

(defun collect-package-classes (package)
  (let (result)
    (do-symbols (symbol package result)
      (let ((class (find-class symbol nil)))
        (when class
          (push class result))))))

;;; First we compute the set union, then we find pairs of symbols that have the
;;; same name, but are not the same symbol. Finally we sort them by name - then
;;; collected pairs are in traversal order. This will produce a lot of garbage
;;; (i.e ACROSS from LOOP, interned variable names etc) - that's why we need to
;;; cross-reference it against defined functions and slots in classes instead of
;;; simply eyeballing them.
(defun symbol-divergence ()
  (let ((silly-sym (collect-package-symbols "SILLY"))
        (climi-sym (collect-package-symbols "CLIMI"))
        (result '()))
    (dolist (symbol silly-sym)
      (when (and (not (member symbol climi-sym))
                 (member symbol climi-sym :test #'string=))
        (push (cons symbol (find symbol climi-sym :test #'string=)) result)))
    (dolist (symbol climi-sym)
      (when (and (not (member symbol silly-sym))
                 (member symbol silly-sym :test #'string=))
        (push (cons symbol (find symbol silly-sym :test #'string=))
              result)))
    (remove-duplicates result :test #'string= :key #'car)))

;;; Compute the floor of our classes. Then we process classes from the bottom to
;;; find slot names that have the same name but not the same package.
(defun class-superset ()
  (let ((all-classes (append (collect-package-classes "SILLY")
                             (collect-package-classes "CLIMI")
                             (collect-package-classes "SILEX")
                             (collect-package-classes "CLIM"))))
    (remove-duplicates all-classes)))

(defun class-bottoms ()
  (labels ((compute-leafs (class)
             (let ((subs (c2mop:class-direct-subclasses class)))
               (if (null subs)
                   (list class)
                   (loop for sub in subs
                         appending (compute-leafs sub))))))
    (remove-duplicates
     (loop for c in (class-superset)
           append (compute-leafs c)))))

;;; Check for falsely shared variables.
(defun compute-variable-drift ()
  (loop for (a . b) in (symbol-divergence)
        when (or (boundp a) (boundp b))
          collect (cons a b)))
(assert (null (compute-variable-drift)))

;;; Check for diverging functions.
(defun compute-function-drift ()
  (loop for (a . b) in (symbol-divergence)
        when (or (and (fboundp a) (fboundp b))
                 (and (fboundp `(setf ,a)) (fboundp `(setf ,b))))
          collect (cons a b)))
(assert (null (compute-function-drift)))

;;; This is a wider test that doesn't necessarily signal problems. This
;;; particular test does not check for slot name collisions, so it is not
;;; conclusive, but it may show problems, most notably class divergence.
(defun compute-meaning-drift ()
  (let ((whitelist
          ;; Manually checked collisions
          '("PARAMETERS"                ;arg name vs ptype accessor
            "OPTIONS"                   ;ditto
            "MULTIPLE-WINDOW"           ;arg name vs tracking-pointer accessor
            "FILLP"                     ;predicate vs slot name
            "COORD-SEQ"                 ;arg name vs output record slot name
            "BBOX"                      ;cached-bbox-mixin vs variable name
            "DRAWING-OPTIONS"           ;arg name vs bordering output accessor
            "LAMBDA-LIST"               ;arg name vs presentation gf accessor
            "CURSORS"                   ;port slot name vs edward-mixin accessor
            "CURSOR"                    ;std pointer slot vs text cursor class
            "CURSOR-SHEET"              ;arg name vs text cursor accessor
            "ORIENTATION"               ;graft slot vs gadget helper
            "NAME"                      ;slot name vs presentation accessor
            )))
   (flet ((meanings (sym)
            (remove nil
                    (list (and (fboundp sym) :operator)
                          (and (fboundp `(setf ,sym)) :setf)
                          (and (boundp sym) :variable)
                          (and (find-class sym nil) :class)))))
     (loop for (a . b) in (symbol-divergence)
           for a-meaning = (meanings a)
           for b-meaning = (meanings b)
           when (and (or a-meaning b-meaning)
                     (not (member (symbol-name a) whitelist :test #'string=)))
             collect `((,a ,@a-meaning)
                       (,b ,@b-meaning))))))
(assert (null (compute-meaning-drift)))

;;; This is a test for the deceptive divergence. We used coalasce slots by using
;;; the same name. And surprise surprise, some regressions were cought!
(defun compute-slot-def-drift ()
  (let ((candidates '())
        (whitelist '("OPEN-P"           ; host gray streams, not an issue
                     "EXTERNAL-FORMAT"  ; host gray streams, not an issue
                     )))
    (dolist (class (class-bottoms) candidates)
      (format *debug-io* "~&Verifying ~a " class)
      (labels ((conflicting (all-slots)
                 (loop for slot in all-slots
                       when (find slot all-slots
                                  :test (lambda (x y)
                                          (and (string= x y)
                                               (not (eq x y))
                                               (not (member x whitelist
                                                            :test #'string=)))))
                         collect slot))
               (collect-class (class)
                 (princ "." *debug-io*)
                 (let* ((slots
                          (mapcar #'c2mop:slot-definition-name
                                  (c2mop:class-direct-slots class))))
                   (loop for sup in (c2mop:class-direct-superclasses class)
                         append (collect-class sup) into supers
                         finally (return (list* (cons class slots) supers))))))
        (let ((supers (collect-class class)))
          (loop for (c1 . s1) in supers do
            (loop for (c2 . s2) in supers
                  for conflicts = (conflicting (append s1 s2))
                  when conflicts do
                    (push (list
                           (cons c1 (intersection s1 conflicts))
                           (cons c2 (intersection s2 conflicts)))
                          candidates))))))))

(compute-slot-def-drift)
(((#<STANDARD-CLASS SILEX:STANDARD-SHEET-INPUT-MIXIN>
   SILEX-INTERNALS::EVENT-QUEUE)
  (#<STANDARD-CLASS CLIM:STANDARD-APPLICATION-FRAME>
   CLIM-INTERNALS::EVENT-QUEUE))
 ((#<STANDARD-CLASS SILEX-SYS:PROPERTIES-MIXIN> SILEX-INTERNALS::PROPERTIES)
  (#<STANDARD-CLASS CLIM:STANDARD-APPLICATION-FRAME>
   CLIM-INTERNALS::PROPERTIES))
 ((#<STANDARD-CLASS CLIM:STANDARD-APPLICATION-FRAME>
   CLIM-INTERNALS::EVENT-QUEUE)
  (#<STANDARD-CLASS SILEX:STANDARD-SHEET-INPUT-MIXIN>
   SILEX-INTERNALS::EVENT-QUEUE))
 ((#<STANDARD-CLASS CLIM:STANDARD-APPLICATION-FRAME>
   CLIM-INTERNALS::PROPERTIES)
  (#<STANDARD-CLASS SILEX-SYS:PROPERTIES-MIXIN> SILEX-INTERNALS::PROPERTIES))
 ((#<STANDARD-CLASS SILEX-SYS:PROPERTIES-MIXIN> SILEX-INTERNALS::PROPERTIES)
  (#<STANDARD-CLASS CLIM:STANDARD-APPLICATION-FRAME>
   CLIM-INTERNALS::PROPERTIES))
 ((#<STANDARD-CLASS CLIM:STANDARD-APPLICATION-FRAME>
   CLIM-INTERNALS::PROPERTIES)
  (#<STANDARD-CLASS SILEX-SYS:PROPERTIES-MIXIN> SILEX-INTERNALS::PROPERTIES))
 ((#<STANDARD-CLASS CLIM:BASIC-PANE> CLIM-INTERNALS::NAME)
  (#<STANDARD-CLASS SILEX:TOP-LEVEL-SHEET-MIXIN> SILEX-INTERNALS::NAME))
 ((#<STANDARD-CLASS SILEX:TOP-LEVEL-SHEET-MIXIN> SILEX-INTERNALS::NAME)
  (#<STANDARD-CLASS CLIM:BASIC-PANE> CLIM-INTERNALS::NAME))
 ((#<STANDARD-CLASS CLIM-CLX:CLX-BASIC-PORT> CLIM-CLX::FONT-FAMILIES)
  (#<STANDARD-CLASS MCCLIM-TRUETYPE:TTF-PORT-MIXIN>
   MCCLIM-TRUETYPE::FONT-FAMILIES))
 ((#<STANDARD-CLASS MCCLIM-TRUETYPE:TTF-PORT-MIXIN>
   MCCLIM-TRUETYPE::FONT-FAMILIES)
  (#<STANDARD-CLASS CLIM-CLX:CLX-BASIC-PORT> CLIM-CLX::FONT-FAMILIES))
 ((#<STANDARD-CLASS CLIM-CLX:CLX-BASIC-PORT> CLIM-CLX::FONT-FAMILIES)
  (#<STANDARD-CLASS MCCLIM-TRUETYPE:TTF-PORT-MIXIN>
   MCCLIM-TRUETYPE::FONT-FAMILIES))
 ((#<STANDARD-CLASS MCCLIM-TRUETYPE:TTF-PORT-MIXIN>
   MCCLIM-TRUETYPE::FONT-FAMILIES)
  (#<STANDARD-CLASS CLIM-CLX:CLX-BASIC-PORT> CLIM-CLX::FONT-FAMILIES)))