Automated Package-Diff Script

compare-cl-cl21.lisp

(mapc #'asdf:load-system '(:iterate :cl21 :alexandria :trivial-cltl2))

(in-package :cl-user)
(defpackage :package-diff
  (:use :cl :iterate :alexandria))

(in-package :package-diff)

(defun package-symbols-intersection (package1 package2)
  (let ((p1 (find-package package1))
        (p2 (find-package package2)))
    (iter 
      (for s1 in-package p1 external-only t)
      (for (values s2 status) = (find-symbol (symbol-name s1) p2))
      (when (and (eq status :external)
                 (not (eq s1 s2)))
        (collect (cons s1 s2))))))

(defun package-symbols-difference (package1 package2)
  (let ((p1 (find-package package1))
        (p2 (find-package package2)))
    (iter 
      (for s1 in-package p1 external-only t)
      (for (values s2 status) = (find-symbol (symbol-name s1) p2))
      (when (null s2)
        (collect s1)))))

(defun max-name-length (symbols)
  (reduce #'max symbols :key (compose #'length #'symbol-name)))

(defun symbol-kind (s)
  (cond
    ((special-operator-p s) :special-operator)
    ((constantp s) :constant)
    ((fboundp s)
     (if (macro-function s)
         :macro
         (typecase (symbol-function s)
           ;(standard-generic-function :standard-generic-function)
           (generic-function :generic-function)
           (function :function))))
    ((find-class s nil) :class)
    ((eq :special (sb-cltl2:variable-information 'x))
     :special-variable)
    ;; ((compiler-macro-function s) :compiler-macro)
    ))

(defun added-entry (s)
  (list s 'added (package-name (symbol-package s))
        (symbol-kind s)))

(defun removed-entry (s)
  (list s 'deleted
        (package-name (symbol-package s))
        (symbol-kind s)))

(defun changed-entry (cons)
  (destructuring-bind (s1 . s2) cons
    (list s1
          'modified
          (package-name (symbol-package s1))
          (symbol-kind s1)
          (package-name (symbol-package s2))
          (symbol-kind s2))))

(defun package-diff (package1 package2 &key
                     (separator " | ")
                     (stream *standard-output*))
  (let ((s stream))
    (pprint-logical-block (s nil)
      (let* ((entries (append (sort
                               (mapcar #'added-entry
                                       (package-symbols-difference package2 package1))
                               #'entry<)
                              (sort
                               (mapcar #'removed-entry
                                       (package-symbols-difference package1 package2))
                               #'entry<)
                              (sort
                               (mapcar #'changed-entry
                                       (package-symbols-intersection package1 package2))
                               #'entry<)))
             (widths (vector 0 0 0 0 0 0))
             (sepl (length separator)))
        (iter (for e in entries)
              (iter (for len in (mapcar (compose #'length #'princ-to-string) e))
                    (for w in-vector widths with-index i)
                    (setf (aref widths i)
                          (max w len))))
        (let ((tabs (iter (for i below 6)
                          (collect
                              (iter (for j to i)
                                    (summing sepl)
                                    (summing (aref widths j)))))))
          (iter (for list in entries)
                (fresh-line s)
                (princ separator s)
                (iter (for elem in list)
                      (for tab in tabs)
                      (princ elem s)
                      (pprint-tab :line tab 0 s)
                      (princ separator s))))))))

;; (defmacro dictionary-ordering

(defun entry< (e1 e2)
  (destructuring-bind (s1 act1 pkgname1 kind1 . rest1) e1
    (destructuring-bind (s2 act2 pkgname2 kind2 . rest2) e2
      (or (string< act1 act2)
          (and (string= act1 act2)
               (or (string< pkgname1 pkgname2)
                   (and (string= pkgname1 pkgname2)
                        ;; symbols are string designators...
                        (or (string< kind1 kind2)
                            (and (string= kind1 kind2)
                                 (or (when (and rest1 rest2)
                                       ;; changed entry...
                                       (destructuring-bind (pkgname1 kind1) rest1
                                         (destructuring-bind (pkgname2 kind2) rest2
                                           (or (string< pkgname1 pkgname2)
                                               (and (string= pkgname1 pkgname2)
                                                    ;; symbols are string designators...
                                                    (or (string< kind1 kind2)
                                                        (and (string= kind1 kind2)
                                                             (string< s1 s2))))))))
                                     (string< s1 s2)))))))))))



;; (package-diff :cl :cl21)
;; (package-diff :cl :cl21 :separators (make-list 4 :initial-element " | "))