; Uses a few undocumented, unexported functions / slots:
; 
; - slot: lispworks-tools::buffers-list of lispworks-tools:editor
; - function: (setf capi::multi-column-list-panel-item-print-functions)
;
; So far, all the undocumented/unexported stuff is in
; customize-editor-buffer-list.
;
; Copyright 2008, Larry Clapp, larry@theclapp.org.
; License: LLGPL.

(defpackage :customize-editor-buffer-list
  (:use :cl :lispworks)
  (:export :add-translation :customize-existing-windows))

(in-package :customize-editor-buffer-list)

(defvar *translations* nil
  "A list of (from to) pairs.  For best results, sort by length of
'from'.  This will make the translation that replaces the most path
apply.")

;; This function is somewhat inefficient, but on the other hand I
;; don't expect to be calling it that much.
(defun add-translation (from to)
  "Add a (from to) translation for the buffer-list."
  (setf *translations*
        (sort (cons (list from to)
                    (remove from *translations*
                            :key #'car
                            :test #'string=))
              #'>
              :key (lambda (pair) (length (car pair))))))

(defun xlat-pathname (item)
  "Apply the (from => to) translations to a pathname in the buffer-list."
  ; princ-to-string was the function shown by the inspector when I
  ; looked at an unmodified instance of the Editor tool.
  (let ((string (princ-to-string item)))
    (loop for (from to) in *translations*
          for index = (search from string) ; nil if not found
          if (eql index 0) ; zerop, of course, barfs if index is nil
          do (return (concatenate 'string to (subseq string (length from))))
          finally (return string))))

(defvar *buffer-list-print-functions*
  (nconc (make-list 4 :initial-element #'princ-to-string)
         (list 'xlat-pathname))
  "The list of print functions for printing the items in the buffer-list.")

(defun customize-editor-buffer-list (interface)
  "Set the print functions for the buffer-list tab in an Editor
window, and set the default sort to be by pathname."
  (when (typep interface 'lispworks-tools:editor)
    (let* ((buffers-list (slot-value interface 'lispworks-tools::buffers-list)))
      (setf (capi::multi-column-list-panel-item-print-functions buffers-list)
            *buffer-list-print-functions*)
      (capi:sorted-object-sort-by buffers-list :pathname))))

(defadvice (capi:display
            track-display
            :after
            :documentation "Set the print functions for the buffer-list tab in a new Editor window.")
    (interface &key &allow-other-keys)
  (customize-editor-buffer-list interface))

;; Run this if you don't load this at startup, and you already have an
;; Editor window open.
(defun customize-existing-windows ()
  (mapcar 'customize-editor-buffer-list
          (capi:screen-interfaces (capi:convert-to-screen))))