Skip to content

Instantly share code, notes, and snippets.

@guicho271828
Last active August 29, 2015 13:56
Show Gist options
  • Save guicho271828/8824742 to your computer and use it in GitHub Desktop.
Save guicho271828/8824742 to your computer and use it in GitHub Desktop.
Automated Package-Diff Script
(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 " | "))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment