Skip to content

Instantly share code, notes, and snippets.

@youz
Created March 15, 2012 07:17
Show Gist options
  • Save youz/2042696 to your computer and use it in GitHub Desktop.
Save youz/2042696 to your computer and use it in GitHub Desktop.
table view mode for #xyzzy
(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))

;;; -*- 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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment