362 lines
13 KiB
EmacsLisp
362 lines
13 KiB
EmacsLisp
;;; pulldown.el --- Visual pulldown menu interface
|
|
|
|
;; Copyright (C) 2009 Tomohiro Matsuyama
|
|
|
|
;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com>
|
|
;; Keywords: lisp
|
|
;; Version: 0.1
|
|
|
|
;; This program 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 program 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile
|
|
(require 'cl))
|
|
|
|
(defgroup pulldown nil
|
|
"Visual pulldown menu interface"
|
|
:group 'lisp
|
|
:prefix "pulldown-")
|
|
|
|
(defface pulldown-default-face
|
|
'((t (:background "lightgray" :foreground "black" :underline "darkgray")))
|
|
"Face for pulldown menu."
|
|
:group 'pulldown)
|
|
|
|
(defface pulldown-default-selection-face
|
|
'((t (:background "steelblue" :foreground "white")))
|
|
"Face for selection."
|
|
:group 'pulldown)
|
|
|
|
(defstruct pulldown
|
|
point row column width height direction overlays
|
|
newline-added
|
|
face selection-face
|
|
cursor offset scroll-top list)
|
|
|
|
(defun pulldown-x-to-string (x)
|
|
"Convert anything to string effeciently."
|
|
(typecase x
|
|
(string x)
|
|
(symbol (symbol-name x))
|
|
(integer (number-to-string x))
|
|
(float (number-to-string x))
|
|
(t (format "%s" x))))
|
|
|
|
(defun pulldown-goto-line (line)
|
|
"Goto `LINE' regarding of narrowing."
|
|
(goto-char (point-min))
|
|
(forward-line (1- line)))
|
|
|
|
(defun pulldown-current-physical-column ()
|
|
"Current physical column. (not logical column)"
|
|
(car (posn-col-row (posn-at-point))))
|
|
|
|
(defun pulldown-last-line-of-buffer ()
|
|
"Return non-nil if at last line of buffer."
|
|
(save-excursion (/= (forward-line) 0)))
|
|
|
|
(defun pulldown-item-propertize (item &rest properties)
|
|
(if (stringp item)
|
|
(apply 'propertize item properties)
|
|
item))
|
|
|
|
(defun pulldown-item-property (item property)
|
|
(if (stringp item)
|
|
(get-text-property 0 property item)))
|
|
|
|
(defun pulldown-set-list (menu list)
|
|
"Set menu list."
|
|
(setf (pulldown-list menu) list
|
|
(pulldown-offset menu) (if (> (pulldown-direction menu) 0)
|
|
0
|
|
(max (- (pulldown-height menu) (length list)) 0))))
|
|
|
|
(defun pulldown-line-overlay (menu line)
|
|
"Return a overlay of `MENU' at `LINE'."
|
|
(aref (pulldown-overlays menu) line))
|
|
|
|
(defun pulldown-hide-line (menu line)
|
|
"Hide `LINE' in `MENU'."
|
|
(let ((overlay (pulldown-line-overlay menu line)))
|
|
(overlay-put overlay 'invisible nil)
|
|
(overlay-put overlay 'after-string nil)))
|
|
|
|
(defun pulldown-show-line (menu line)
|
|
"Show `LINE' in `MENU'."
|
|
(overlay-put (pulldown-line-overlay menu line) 'invisible t))
|
|
|
|
(defun pulldown-set-line-item (menu line item &optional face)
|
|
"Set list of `LINE' in `MENU'."
|
|
(let ((overlay (pulldown-line-overlay menu line)))
|
|
(overlay-put overlay 'real-item item)
|
|
(overlay-put overlay
|
|
'after-string
|
|
(concat (overlay-get overlay 'prefix)
|
|
(propertize (pulldown-create-line-string menu item) 'face face)
|
|
(overlay-get overlay 'postfix)))))
|
|
|
|
(defun pulldown-create-line-string (menu item)
|
|
"Create string for showing `ITEM' in `MENU'."
|
|
(loop with string = (pulldown-x-to-string item)
|
|
with width = 0
|
|
with menu-width = (pulldown-width menu)
|
|
for length from 0
|
|
for c in (append string nil)
|
|
while (<= (incf width (char-width c)) menu-width)
|
|
finally return
|
|
(let ((string-width (string-width (if (< length (length string))
|
|
(substring string 0 length)
|
|
string))))
|
|
(if (< string-width menu-width)
|
|
;; Padding
|
|
(concat string (make-string (- menu-width string-width) ? ))
|
|
string))))
|
|
|
|
(defun pulldown-hide (menu)
|
|
"Hide `MENU'."
|
|
(dotimes (i (pulldown-height menu))
|
|
(pulldown-hide-line menu i)))
|
|
|
|
(defun pulldown-draw (menu)
|
|
"Draw `MENU'."
|
|
(loop with height = (pulldown-height menu)
|
|
with list = (pulldown-list menu)
|
|
with cursor = (pulldown-cursor menu)
|
|
with scroll-top = (pulldown-scroll-top menu)
|
|
with offset = (pulldown-offset menu)
|
|
for o from offset
|
|
for i from scroll-top
|
|
for item in (nthcdr scroll-top list)
|
|
while (< o height)
|
|
|
|
do
|
|
;; Show line and set item to the line
|
|
(pulldown-show-line menu o)
|
|
(pulldown-set-line-item
|
|
menu o item
|
|
(if (= i cursor)
|
|
(or (pulldown-item-property item 'selection-face) (pulldown-selection-face menu))
|
|
(or (pulldown-item-property item 'menu-face) (pulldown-face menu))))
|
|
|
|
finally
|
|
;; Hide remaining lines
|
|
(if (> (pulldown-direction menu) 0)
|
|
(while (< o height)
|
|
(pulldown-hide-line menu o)
|
|
(incf o))
|
|
(dotimes (o offset)
|
|
(pulldown-hide-line menu o)))))
|
|
|
|
(defun pulldown-next (menu)
|
|
"Select next item."
|
|
(let ((height (pulldown-height menu))
|
|
(cursor (1+ (pulldown-cursor menu)))
|
|
(scroll-top (pulldown-scroll-top menu))
|
|
(length (length (pulldown-list menu))))
|
|
(cond
|
|
((>= cursor length)
|
|
;; Back to first page
|
|
(setq cursor 0
|
|
scroll-top 0))
|
|
((= cursor (+ scroll-top height))
|
|
;; Go to next page
|
|
(setq scroll-top (min (1+ scroll-top) (max (- length height) 0)))))
|
|
(setf (pulldown-cursor menu) cursor
|
|
(pulldown-scroll-top menu) scroll-top)
|
|
(pulldown-draw menu)))
|
|
|
|
(defun pulldown-previous (menu)
|
|
"Select previous item."
|
|
(let ((height (pulldown-height menu))
|
|
(cursor (1- (pulldown-cursor menu)))
|
|
(scroll-top (pulldown-scroll-top menu))
|
|
(length (length (pulldown-list menu))))
|
|
(cond
|
|
((< cursor 0)
|
|
;; Go to last page
|
|
(setq cursor (1- length)
|
|
scroll-top (max (- length height) 0)))
|
|
((= cursor (1- scroll-top))
|
|
;; Go to previous page
|
|
(decf scroll-top)))
|
|
(setf (pulldown-cursor menu) cursor
|
|
(pulldown-scroll-top menu) scroll-top)
|
|
(pulldown-draw menu)))
|
|
|
|
(defun* pulldown-create (point width height
|
|
&key
|
|
(face 'pulldown-default-face)
|
|
(selection-face 'pulldown-default-selection-face))
|
|
"Create pulldown menu."
|
|
(save-excursion
|
|
(goto-char point)
|
|
(let* ((row (line-number-at-pos))
|
|
(column (pulldown-current-physical-column))
|
|
(overlays (make-vector height nil))
|
|
(window (selected-window))
|
|
(window-start (window-start))
|
|
(window-hscroll (window-hscroll))
|
|
(window-width (window-width))
|
|
(right (+ column width))
|
|
(direction (if (and (> row height)
|
|
(> height (- (max 1 (- (window-height)
|
|
(if mode-line-format 1 0)
|
|
(if header-line-format 1 0)))
|
|
(count-lines window-start (point)))))
|
|
-1
|
|
1))
|
|
(newline-added (save-excursion
|
|
(goto-char (point-max))
|
|
(unless (bolp)
|
|
(newline)
|
|
t)))
|
|
current-column)
|
|
(if (and (> right window-width)
|
|
(>= right width)
|
|
(>= column width))
|
|
(decf column width))
|
|
(dotimes (i height)
|
|
(let (overlay begin w (prefix "") (postfix ""))
|
|
(if (>= emacs-major-version 23)
|
|
(vertical-motion (cons column direction))
|
|
(vertical-motion direction)
|
|
(move-to-column (+ (current-column) column)))
|
|
(setq current-column (pulldown-current-physical-column))
|
|
|
|
(when (> current-column column)
|
|
(backward-char)
|
|
(setq current-column (pulldown-current-physical-column)))
|
|
(when (< current-column column)
|
|
;; Extend short buffer lines by menu prefix (line of spaces)
|
|
(setq prefix (make-string (+ (if (= current-column 0)
|
|
(- window-hscroll (current-column))
|
|
0)
|
|
(- column current-column))
|
|
? )))
|
|
|
|
(setq begin (point))
|
|
(setq w (+ width (length prefix)))
|
|
(while (and (not (eolp)) (> w 0))
|
|
(decf w (char-width (char-after)))
|
|
(forward-char))
|
|
(if (< w 0)
|
|
(setq postfix (make-string (- w) ? )))
|
|
(if (pulldown-last-line-of-buffer)
|
|
(setq postfix (concat postfix "\n")))
|
|
|
|
(setq overlay (make-overlay begin (point)))
|
|
(overlay-put overlay 'window window)
|
|
(overlay-put overlay 'prefix prefix)
|
|
(overlay-put overlay 'postfix postfix)
|
|
(overlay-put overlay 'width width)
|
|
(aset overlays
|
|
(if (> direction 0) i (- height i 1))
|
|
overlay)))
|
|
(loop for p from 100
|
|
for overlay in (nreverse (append overlays nil))
|
|
do (overlay-put overlay 'priority p))
|
|
(make-pulldown :point point
|
|
:row row
|
|
:column column
|
|
:width width
|
|
:height height
|
|
:direction direction
|
|
:newline-added newline-added
|
|
:face face
|
|
:selection-face selection-face
|
|
:cursor 0
|
|
:scroll-top 0
|
|
:list '()
|
|
:overlays overlays))))
|
|
|
|
(defun pulldown-delete (menu)
|
|
(mapcar 'delete-overlay (pulldown-overlays menu))
|
|
(setf (pulldown-overlays menu) nil)
|
|
(if (pulldown-newline-added menu)
|
|
(save-excursion
|
|
(goto-char (point-max))
|
|
(if (and (bolp) (eolp))
|
|
(delete-char -1)))))
|
|
|
|
(defun pulldown-live-p (menu)
|
|
(and menu (pulldown-overlays menu) t))
|
|
|
|
(defun pulldown-preferred-width (list)
|
|
"Return preferred width of pulldown menu to show `LIST' beautifully."
|
|
(loop for item in list
|
|
maximize (string-width (pulldown-x-to-string item)) into width
|
|
finally return (* (ceiling (/ (or width 0) 10.0)) 10)))
|
|
|
|
(defun pulldown-lookup-key-by-event (function event)
|
|
(or (funcall function (vector event))
|
|
(if (symbolp event)
|
|
(let ((mask (get event 'event-symbol-element-mask)))
|
|
(if mask
|
|
(funcall function (vector (logior (or (get (car mask) 'ascii-character) 0)
|
|
(cadr mask)))))))))
|
|
|
|
(defun* pulldown-event-loop (menu keymap fallback &optional message &aux event binding)
|
|
(unwind-protect
|
|
(block nil
|
|
(while (and (pulldown-live-p menu)
|
|
(setq event (progn (clear-this-command-keys) (read-event message))))
|
|
(if (eq event 'Quit)
|
|
(return nil))
|
|
(setq binding (pulldown-lookup-key-by-event (lambda (key) (lookup-key keymap key)) event))
|
|
(cond
|
|
((eq binding 'pulldown-select)
|
|
(return (nth (pulldown-cursor menu) (pulldown-list menu))))
|
|
((eq binding 'pulldown-next)
|
|
(pulldown-next menu))
|
|
((eq binding 'pulldown-previous)
|
|
(pulldown-previous menu))
|
|
(binding
|
|
(call-interactively binding))
|
|
(t
|
|
(funcall fallback event (pulldown-lookup-key-by-event (lambda (key) (key-binding key)) event))))))
|
|
(pulldown-delete menu)))
|
|
|
|
(defun pulldown-default-fallback (event default))
|
|
|
|
(defun* pulldown-menu (list
|
|
&key
|
|
(width (pulldown-preferred-width list))
|
|
(height 10)
|
|
(keymap pulldown-keymap)
|
|
(fallback 'pulldown-default-fallback)
|
|
message
|
|
&aux menu event)
|
|
(setq menu (pulldown-create (point) width height))
|
|
(pulldown-set-list menu list)
|
|
(pulldown-draw menu)
|
|
(pulldown-event-loop menu keymap fallback message))
|
|
|
|
(defvar pulldown-keymap
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map "\r" 'pulldown-select)
|
|
|
|
(define-key map "\C-n" 'pulldown-next)
|
|
(define-key map "\C-p" 'pulldown-previous)
|
|
(define-key map [down] 'pulldown-next)
|
|
(define-key map [up] 'pulldown-previous)
|
|
map))
|
|
|
|
(provide 'pulldown)
|
|
;;; pulldown.el ends here
|