;;;; Port to Climacs of Michael Webers CL:DEFCLASS formatter for GNU
;;;; Emacs: http://foldr.org/~michaelw/emacs/mwe-defclass-formatter.el
;;;;
;;;; Troels Henriksen (athas@sigkill.dk) is guilty of this.

;;; Commentary: Does not really work well at all. Do not put
;;;   reader-conditionals, comments, linebreaks or other nasty things
;;;   inside your slot definitions, or this code will break. On the
;;;   plus side, you get to keep both pieces.

(in-package :climacs-lisp-syntax)

(defun token-column-widths (token)
  "Return list of column widths for `token'."
  (mapcar #'(lambda (child)
              (slot-value child 'size))
          (remove-if-not #'(lambda (child)
                             (typep child 'form))
                         (children token))))

(defun align-sexp-columns (mark syntax column-widths)
  "Align forms in s-expression after `mark' according to
`column-widths'."
  (when (forward-down mark syntax 1 nil)
    (loop
       for width-cons on column-widths
       for width = (first width-cons)
       for last-width = (null (rest width-cons))
       do (handler-case (progn
                          ;; We move two expressions forward to check
                          ;; whether it is the last expression in the
                          ;; list. This is not very pretty.
                          (forward-expression mark syntax 2)
                          ;; Go back again.
                          (backward-expression mark syntax 2)
                          (forward-expression mark syntax)
                          (let ((after-offset (offset mark)))
                            (backward-expression mark syntax 1)
                            (let ((before-offset (offset mark)))
                              (forward-expression mark syntax 1)
                              (let ((difference (1+ (- width (- after-offset
                                                                before-offset)))))
                               (when (and (plusp difference)
                                          (not last-width))
                                 (just-n-spaces mark
                                                difference))))
                            (update-syntax (buffer syntax)
                                           syntax)))
            ;; ON ERROR RESUME NEXT
            (motion-limit-error ()
              (return)))
       finally (backward-up mark syntax 1 nil))))

(defun align-forms-as-columns (beg end syntax)
  "Align s-expressions in region in columns."
  (let* ((columns (loop
                     while (forward-expression beg syntax 1 nil)
                     until (mark> beg end)
                     collect (token-column-widths (form-before syntax (offset beg)))))
         (max-column-widths (loop
                               for cols = columns then (mapcar #'cdr cols)
                               while (some #'consp cols)
                               collect (apply #'max
                                              (mapcar #'(lambda (i)
                                                          (or i 0))
                                                      (mapcar #'car cols))))))
    (loop
       while (backward-expression beg syntax 1 nil)
       do (align-sexp-columns (clone-mark beg) syntax max-column-widths))))

(define-command (com-prettify-defclass :name t :command-table lisp-table)
    ()
  "Aligns slots of the Common Lisp DEFCLASS form after point.
Example (| denotes cursor position):

|(defclass identifier ()
   ((name :reader name-of :initarg :name)
    (location :reader location-of :initarg :location)
    (scope :accessor scope-of :initarg :scope)
    (definition :accessor definition-of :initform nil))
   (:default-initargs :scope *current-scope*))

is formatted to:

|(defclass identifier ()
   ((name       :reader   name-of       :initarg  :name)
    (location   :reader   location-of   :initarg  :location)
    (scope      :accessor scope-of      :initarg  :scope)
    (definition :accessor definition-of :initform nil))
   (:default-initargs :scope *current-scope*))"
  (let* ((pane (current-window))
         (buffer (buffer pane))
         (syntax (syntax buffer))
         (point (point pane)))
    (cond ((eq (form-operator (form-after syntax (offset point)) syntax)
               'defclass)
           (forward-down point syntax)
           (forward-expression point syntax 3)
           (let ((end (clone-mark point)))
             (forward-expression end syntax)
             (align-forms-as-columns
              (progn (forward-down point syntax)
                     point)
              end
              syntax)
             (backward-up point syntax 2))))))