my-emacs-d/elpa/go-20160430.1739/list-buffer.el

193 lines
7.0 KiB
EmacsLisp
Raw Normal View History

2016-09-15 11:54:46 +00:00
;;; list-buffer.el --- view a list as a table in a buffer
;; Copyright (C) 2013 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte.eric@gmail.com>
;; Created: 2013-08-02
;; Version: 0.1
;; Keywords: list buffer cl
;; This software is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Code:
(eval-when-compile (require 'cl))
(require 'go-util)
(defvar *buffer-list* nil
"List associated with the current list buffer.")
(defvar *buffer-headers* nil
"Headers associated with the current list buffer.")
(defvar *buffer-width* nil
"Width associated with the current list buffer.")
(defvar *enter-function* nil
"Function used to enter a list element.
The function should take two arguments, the current row and
column respectively and may access the current buffer list
through the `*buffer-list*' variable.")
(defvar *refresh-function* nil
"Function used to refresh a list element or the whole list.
The function should take two arguments, the current row and
column respectively and may access the current buffer list
through the `*buffer-list*' variable.")
(defun list-buffer-create
(buffer list &optional headers enter-function refresh-function)
(pop-to-buffer buffer)
(list-mode)
(set (make-local-variable '*buffer-width*) (window-total-width))
(set (make-local-variable '*buffer-list*) list)
(set (make-local-variable '*buffer-headers*)
(mapcar (curry #'format "%s") headers))
(set (make-local-variable '*enter-function*)
(or enter-function
(lambda (row col)
(message "enter %S" (nth col (nth row *buffer-list*))))))
(set (make-local-variable '*refresh-function*)
(or refresh-function
(lambda (row col)
(message "refresh %S" (nth col (nth row *buffer-list*))))))
;; refresh every time the buffer changes size
(set (make-local-variable 'window-size-change-functions)
(cons (lambda (b)
(when (or (not (numberp *buffer-width*))
(not (equal *buffer-width* (window-total-width))))
(set '*buffer-width* (window-total-width))
(list-buffer-refresh)))
window-size-change-functions))
(goto-char (point-min))
(list-buffer-refresh))
(defun list-format-row (widths row &optional row-num)
(cl-flet ((num (type number string)
(put-text-property 0 (length string) type number string)
string))
(let ((col 0))
(num :row row-num
(apply #'concat
(cl-mapcar
(lambda (width cell)
(prog1
(num :col col
(if (< (length cell) width)
(concat cell
(make-list (- width (length cell))
?\ ))
(concat (subseq cell 0 (- width 2)) "")))
(incf col)))
widths row))))))
(defun list-buffer-refresh ()
(when *buffer-list*
(let* ((start (point))
(strings (mapcar (curry #'mapcar (curry #'format "%s")) *buffer-list*))
(lengths (mapcar (curry #'mapcar #'length)
(if *buffer-headers*
(cons *buffer-headers* strings)
strings)))
(widths (apply #'cl-mapcar (compose '1+ #'max) lengths))
;; scale widths by buffer width
(widths (mapcar (compose #'floor (curry #'* (/ (window-total-width)
(float (apply #'+ widths)))))
widths)))
;; write headers
(when *buffer-headers*
(set (make-local-variable 'header-line-format)
(concat " " (list-format-row widths *buffer-headers*))))
;; write rows
(delete-region (point-min) (point-max))
(insert (mapconcat (compose (curry #'apply #'list-format-row widths) #'reverse)
(indexed strings) "\n"))
(goto-char start))))
(defun list-buffer-sort (col predicate)
(set '*buffer-list* (cl-sort *buffer-list* predicate :key (curry #'nth col)))
(list-buffer-refresh))
(defun list-current-row () (get-text-property (point) :row))
(defun list-current-col () (get-text-property (point) :col))
(defun list< (a b)
(cond
((and (numberp a) (numberp b) (< a b)))
((and (stringp a) (stringp b) (string< a b)))))
(defun list> (a b)
(cond
((and (numberp a) (numberp b) (> a b)))
((and (stringp a) (stringp b) (string> a b)))))
(defun list-up ()
(interactive)
(list-buffer-sort (get-text-property (point) :col) #'list<))
(defun list-down ()
(interactive)
(list-buffer-sort (get-text-property (point) :col) #'list>))
(defun list-enter ()
(interactive)
(funcall *enter-function* (list-current-row) (list-current-col)))
(defun list-refresh ()
(interactive)
(funcall *refresh-function* (list-current-row) (list-current-col)))
(defun list-filter ()
(interactive)
(error "not implemented."))
(defun list-move-col (direction)
(cl-flet ((col () (or (get-text-property (point) :col) start-col)))
(let ((start-col (col)))
(while (= start-col (col))
(case direction
(:forward (forward-char))
(:backward (backward-char))))
(when (eql direction :backward)
(let ((end-col (col)))
(while (= end-col (col)) (backward-char))
(forward-char))))))
(defun list-next-col () (interactive) (list-move-col :forward))
(defun list-prev-col () (interactive) (list-move-col :backward))
(defvar list-mode-map
(let ((map (make-sparse-keymap)))
;; navigation
(define-key map (kbd "j") 'next-line)
(define-key map (kbd "k") 'previous-line)
(define-key map (kbd "u") 'scroll-down-command)
(define-key map (kbd "<tab>") 'list-next-col)
(define-key map (kbd "<S-iso-lefttab>") 'list-prev-col)
;; list functions
(define-key map (kbd "<up>") 'list-up)
(define-key map (kbd "<down>") 'list-down)
(define-key map (kbd "f") 'list-filter)
(define-key map (kbd "r") 'list-refresh)
(define-key map (kbd "RET") 'list-enter)
(define-key map (kbd "q") 'bury-buffer)
map)
"Keymap for `list-mode'.")
(define-derived-mode list-mode nil "list"
"Major mode for viewing a list.")
(provide 'list-buffer)
;;; list-buffer.el ends here