table view mode for #xyzzy

example.md

(let ((fields '("Buffer" "Size" "Path"))
      (data (loop for b in (buffer-list) collect
              (list (buffer-name b) (buffer-size b) (get-buffer-file-name b))))
      (header '(("Buffer List" :bold t :foreground 7 :background 14 :extend t))))
  (tbl:create-table-view "*buffers*" fields data :header-lines header))

table-view.l

;;; -*- mode:lisp; package:table-view -*-

;; Copyright (c) 2012  Yousuke Ushiki
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.

#|
;; example
(let ((fields '("Buffer" "Size" "Path"))
      (data (loop for b in (buffer-list) collect
              (list (buffer-name b) (buffer-size b) (get-buffer-file-name b))))
      (header '(("Buffer List" :bold t :foreground 7 :background 14 :extend t))))
  (tbl:create-table-view "*buffers*" fields data :header-lines header))
|#

(provide "table-view")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "cmu_loop"))

(defpackage :table-view
  (:nicknames :tbl)
  (:use :lisp :editor))

(in-package :table-view)

(export '(*column-max-width*
          *current-row-style*
          *current-cell-style*
          *border-line-style*
          *keymap*
        ; functions
          create-table-view
          row-index
          column-index
          current-row-data
          current-cell-data
          selected-data
        ; commands
          next-cell
          previous-cell
          next-row
          previous-row
          goto-left-most
          goto-right-most
          goto-bottom
          goto-top
          start-cell-selection
          cancel-cell-selection
          select-all-cells
          copy-selected-cells
          ))

(defvar *current-row-style* '(:foreground 7 :background 12))
(defvar *current-cell-style* '(:foreground 7 :background 10))
(defvar *border-line-style* '(:foreground 15))
(defvar *column-max-width* 50)
(defvar *keymap* nil)

(unless *keymap*
  (setq *keymap* (make-sparse-keymap))
  (define-key *keymap* #\TAB 'next-cell)
  (define-key *keymap* #\n 'next-row)
  (define-key *keymap* #\p 'previous-row)
  (define-key *keymap* #\f 'next-cell)
  (define-key *keymap* #\b 'previous-cell)
  (define-key *keymap* #\h 'previous-cell)
  (define-key *keymap* #\j 'next-row)
  (define-key *keymap* #\k 'previous-row)
  (define-key *keymap* #\l 'next-cell)
  (define-key *keymap* #\a 'goto-left-most)
  (define-key *keymap* #\e 'goto-right-most)
  (define-key *keymap* #\N 'goto-bottom)
  (define-key *keymap* #\P 'goto-top)
  (define-key *keymap* #\H 'goto-left-most)
  (define-key *keymap* #\J 'goto-bottom)
  (define-key *keymap* #\K 'goto-top)
  (define-key *keymap* #\L 'goto-right-most)
  (define-key *keymap* #\s 'start-cell-selection)
  (define-key *keymap* #\S 'select-all-cells)
  (define-key *keymap* #\C 'copy-selected-cells)
  )

(defvar-local *table* nil)


;;; utilities
(defmacro whenlet (var test &body body)
  `(let ((,var ,test)) (when ,var ,@body)))

(defun string-width (str)
  (let ((w 0))
    (dotimes (i (length str))
      (incf w (char-columns (char str i))))
    w))

(defun shrink-string (str width)
  (let ((str (substitute-string str "\n" "\\n"))
        (cw 0))
    (subseq str 0
            (position-if #'(lambda (c) (> (incf cw (char-columns c)) width))
                         str))))

(defun bol-point (&optional point)
  (save-excursion
    (when point
      (goto-char point))
    (goto-bol)
    (point)))

(defun eol-point (&optional point)
  (save-excursion
    (when point
      (goto-char point))
    (goto-eol)
    (point)))


;;; table-view structure
(defstruct (table-view (:conc-name "table-"))
  field-names data selection-anchor
  (column-width (calc-column-width field-names data)))

(defun table-rows-count-count (table)
  (length (table-data table)))

(defun table-columns-count (table)
  (length (table-field-names table)))

(defun table-cell-value (table r c)
  (when (and (< -2 r (table-rows-count-count table))
             (< -2 c (table-columns-count table)))
    (nth c (nth (1+ r) (cons (table-field-names table)
                             (table-data table))))))

(defun table-row (table r)
  (if (= r -1)
      (table-field-names table)
    (nth r (table-data table))))

(defun table-range (table cell1 cell2)
  (let ((data (table-data table))
        (top (min (car cell1) (car cell2)))
        (left (min (cadr cell1) (cadr cell2)))
        (bottom (max (car cell1) (car cell2)))
        (right (max (cadr cell1) (cadr cell2))))
    (mapcar #'(lambda (rec) (subseq rec left (1+ right)))
            (if (< top 0)
                (cons (table-field-names table)
                      (subseq data 0 (1+ bottom)))
              (subseq data top (1+ bottom))))))

(defun calc-column-width (field-names data)
  (let ((colwidth (mapcar #'(lambda (f) (string-width (princ-to-string f)))
                          field-names)))
    (dolist (l data)
      (setq colwidth
            (mapcar #'(lambda (w e)
                        (min *column-max-width*
                             (max w (string-width (format nil "~A" e)))))
                    colwidth l)))
    colwidth))

(defun print-record (rec row-number colwidth &optional (sep #\|))
  (fresh-line)
  (loop
    for d in rec
    for w in colwidth
    for c from 0
    for p = #0=(buffer-stream-point *standard-output*)
    do
    (format t "~A~VA" sep w (shrink-string (princ-to-string (or d "")) w))
    #1=(apply #'set-text-attribute p (1+ p) `(cell ,row-number ,c) *border-line-style*)
    finally
    (let (c (p #0#)) (princ sep) #1#)))

(defun print-table (table buffer &optional point)
  (save-excursion
    (set-buffer buffer)
    (unless point (setq point (point-max)))
    (let ((read-only? buffer-read-only)
          (fields (table-field-names table))
          (data (table-data table))
          (colwidth (table-column-width table)))
      (setq buffer-read-only nil)
      (with-output-to-buffer (buffer point)
        (print-record fields -1 colwidth)
        (print-record (mapcar #'(lambda (w) (format nil "~V@{-~}" w t))
                              colwidth)
                      nil colwidth #\+)
        (let ((row -1))
          (dolist (rec data)
            (print-record rec (incf row) colwidth))))
      (setq buffer-read-only read-only?)))
  t)


;;; cursor
(defun cell-address (&optional (point (point)))
  (multiple-value-bind (from to tag)
      (find-text-attribute 'cell :start (bol-point point) :end (1+ point)
                           :from-end t :key #'safe-car)
    (when tag (cdr tag))))

(defun row-index (&optional (point (point)))
  (car (cell-address point)))

(defun column-index (&optional (point (point)))
  (cadr (cell-address point)))

(defun current-row-data ()
  (whenlet r (row-index)
    (table-row *table* r)))

(defun current-cell-data ()
  (whenlet rc (cell-address)
    (apply #'table-cell-value *table* rc)))

(defun next-cell (&optional (n 1))
  (interactive "p")
  (let ((rc (cell-address)))
    (if rc
        (let* ((cm (table-columns-count *table*))
               (r (car rc))
               (next (+ n (or (cadr rc) (1- cm))))
               (nr (+ (car rc) (floor next cm)))
               (nc (mod next cm)))
          (whenlet p (find-text-attribute `(cell ,nr ,nc) :start (point-min) :test #'equal)
            (goto-char (1+ p))))
      (forward-char n))))

(defun previous-cell (&optional (n 1))
  (interactive "p")
  (next-cell (- n)))

(defun next-row (&optional (n 1))
  (interactive "p")
  (next-line n)
  (whenlet rc (cell-address)
    (when (null (car rc))
      (next-line (signum n)))))

(defun previous-row (&optional (n 1))
  (interactive "p")
  (next-row (- n)))

(defun goto-left-most ()
  (interactive)
  (next-cell (- (column-index))))

(defun goto-right-most ()
  (interactive)
  (next-cell (- (table-columns-count *table*) 1 (current-column-index))))

(defun goto-top ()
  (interactive)
  (let ((vc (current-column)))
    (whenlet p (find-text-attribute '(cell 0 0)
                                    :start (point-min) :test #'equal)
      (goto-char p)
      (goto-column vc))))

(defun goto-bottom ()
  (interactive)
  (let ((vc (current-column)))
    (whenlet p (find-text-attribute `(cell ,(1- (table-rows-count-count *table*)) 0)
                                    :from-end t :end (point-max) :test #'equal)
      (goto-char p)
      (goto-column vc))))


;;; selection
(defun start-cell-selection ()
  (interactive)
  (whenlet rc (cell-address)
    (setf (table-selection-anchor *table*) rc)))

(defun cancel-cell-selection ()
  (interactive)
  (setf (table-selection-anchor *table*) nil))

(defun select-all-cells ()
  (interactive)
  (setf (table-selection-anchor *table*) '(-1 0))
  (goto-right-most)
  (goto-bottom))

(defun cancel-selection-on-quit ()
  (when (eq *this-command* 'quit)
    (cancel-cell-selection)
    (highlight-cells)))

(defun selected-data ()
  (whenlet rc (cell-address)
    (whenlet anchor (table-selection-anchor *table*)
      (table-range *table* rc anchor))))

(defun copy-selected-cells ()
  (interactive)
  (let ((selected (selected-data)))
    (copy-to-clipboard
     (if selected
         (format nil "~{~{~@[~A~]~^\t~}~%~}" selected)
       (format nil "~@[~A~]" (apply #'table-cell-value *table* rc))))
    (message "Copied")))


;;; highlight
(defun highlight-row (cr cc)
  (save-excursion
    (goto-bol)
    (loop for c from 0
      with p = (1+ (point))
      with end = (eol-point) do
      (let ((next (find-text-attribute 'cell :start p :end end :key #'safe-car)))
        (unless next (return-from highlight-row))
        (if (eql c cc)
            (when *current-cell-style*
              (apply #'set-text-attribute p next 'highlight *current-cell-style*))
          (when *current-row-style*
            (apply #'set-text-attribute p next 'highlight *current-row-style*)))
        (setq p (1+ next))))))

(defun highlight-selection (from-r from-c to-r to-c)
  (let ((top (min from-r to-r))
        (left (min from-c to-c))
        (bottom (max from-r to-r))
        (right (max from-c to-c)))
    (save-excursion
      (goto-char (find-text-attribute `(cell ,top ,left) :from-end t :test #'equal))
      (loop for r from top to bottom do
        (loop for c from left to right do
          (let* ((p (1+ (find-text-attribute `(cell ,r ,c) :test #'equal)))
                 (next (find-text-attribute 'cell :start p :key #'safe-car)))
            (if (or (and (= from-r r) (= from-c c))
                    (and (= to-r r) (= to-c c)))
                (when *current-cell-style*
                  (apply #'set-text-attribute p next 'highlight *current-cell-style*))
              (when *current-row-style*
                (apply #'set-text-attribute p next 'highlight *current-row-style*)))
            (goto-char next)))))))

(defun highlight-cells ()
  (whenlet rc (and (or *current-row-style* *current-cell-style*)
                   (cell-address))
    (delete-text-attributes 'highlight)
    (let ((anchor (table-selection-anchor *table*)))
      (if anchor
          (apply #'highlight-selection `(,@anchor ,@rc))
        (apply #'highlight-row rc)))))


;;; major mode
(defun table-view-mode ()
  (interactive)
  (kill-all-local-variables)
  (setq buffer-mode 'table-view-mode
        mode-name "table-view"
        kept-undo-information nil
        need-not-save t
        auto-save nil)
  (unless (local-variable-p '*post-command-hook*)
    (make-local-variable '*post-command-hook*))
  (add-hook '*post-command-hook* 'cancel-selection-on-quit)
  (add-hook '*post-command-hook* 'highlight-cells)
  (use-keymap *keymap*))


(defun create-table-view (bufname field-names data &key header-lines popup-win virt-p)
  (let ((buf (create-new-buffer bufname))
        (table (make-table-view  :field-names field-names :data data)))
    (save-excursion
      (set-buffer buf)
      (toggle-read-only nil)
      (erase-buffer buf)
      (table-view-mode)
      (when header-lines
        (with-output-to-buffer (buf)
          (dolist (h header-lines)
            (let ((p (buffer-stream-point *standard-output*))
                  (text (if (consp h) (car h) h))
                  (style (if (consp h) (cdr h)9)))
              (format t "~A~&" text)
              (apply #'set-text-attribute p (point-max) 'header style)))))
      (setq *table* table)
      (print-table *table* buf)
      (toggle-read-only t))
    buf))