mirror of
https://github.com/stumpwm/stumpwm-contrib.git
synced 2026-09-10 07:26:25 -04:00
Merge pull request #240 from szos/master
Add CLIM based messaging module
This commit is contained in:
David
GitHub
commit
619c348e70
13
README.org
13
README.org
|
|
@ -77,9 +77,9 @@ Advertise your module here, open a PR and include a org-mode link!
|
|||
# --
|
||||
** Media
|
||||
- [[./media/amixer/README.org][amixer]] :: Manipulate the volume using amixer
|
||||
- [[./media/stump-radio/README.org][stump-radio]] :: Minimalistic mplayer-based radio for StumpWM.
|
||||
- [[./media/stump-volume-control/README.org][stump-volume-control]] :: Minimalistic amixer-based volume control for StumpWM.
|
||||
- [[./media/stumpwm-sndioctl/README.org][stumpwm-sndioctl]] :: Interface to OpenBSD's sndioctl from StumpWM.
|
||||
- [[./media/stump-radio/README][stump-radio]] :: Minimalistic mplayer-based radio for StumpWM.
|
||||
- [[./media/stump-volume-control/README][stump-volume-control]] :: Minimalistic amixer-based volume control for StumpWM.
|
||||
- [[./media/stumpwm-sndioctl/README.md][stumpwm-sndioctl]] :: Interface to OpenBSD's sndioctl from StumpWM.
|
||||
** Minor Modes
|
||||
- [[./minor-mode/mpd/README.org][mpd]] :: Displays information about the music player daemon (MPD).
|
||||
- [[./minor-mode/notifications/README.org][notifications]] :: A notification library that sends notifications to the modeline via stumpish or from stumpwm itself.
|
||||
|
|
@ -107,7 +107,7 @@ Advertise your module here, open a PR and include a org-mode link!
|
|||
- [[./util/desktop-entry/README.org][desktop-entry]] :: desktop-entry
|
||||
- [[./util/end-session/README.org][end-session]] :: Provides commands to stumpwm that allow the user to shutdown, restart, and logoff through the stumpwm UI
|
||||
- [[./util/globalwindows/README.org][globalwindows]] :: Manipulate all windows in the current X session
|
||||
- [[./util/gnu-pw-mgr/README.org][gnu-pw-mgr]] :: Reconstruct passwords with gnu-pw-mgr
|
||||
- [[./util/gnu-pw-mgr/README.md][gnu-pw-mgr]] :: Reconstruct passwords with gnu-pw-mgr
|
||||
- [[./util/golden-ratio/README.org][swm-golden-ratio]] :: Resize the currently focused frame to the golden ratio
|
||||
- [[./util/kbd-layouts/README.org][kbd-layouts]] :: Keyboard layout switcher for StumpWM
|
||||
- [[./util/logitech-g15-keysyms/README.org][logitech-g15-keysyms]] :: Describe logitech-g15-keysyms here
|
||||
|
|
@ -128,10 +128,11 @@ Advertise your module here, open a PR and include a org-mode link!
|
|||
- [[./util/stump-lock/README.org][stump-lock]] :: Screen locker in StumpWM
|
||||
- [[./util/stump-nm/README.org][stump-nm]] :: StumpWM integration with NetworkManager
|
||||
- [[./util/surfraw/README.org][surfraw]] :: Integrates surfraw with stumpwm.
|
||||
- [[./util/swm-emacs/README.org][swm-emacs]] :: A set of utilities for launching the beast.
|
||||
- [[./util/swm-clim-message/README.org][swm-clim-message]] :: Display StumpWM messages and menus through CLIM
|
||||
- [[./util/swm-emacs/README.txt][swm-emacs]] :: A set of utilities for launching the beast.
|
||||
- [[./util/swm-gaps/README.org][swm-gaps]] :: Pretty (useless) gaps for StumpWM
|
||||
- [[./util/swm-ssh/README.org][swm-ssh]] :: A simple menu selector for ssh to a remote host for stumpwm that parses your ssh config to get available hosts
|
||||
- [[./util/ttf-fonts/README.org][ttf-fonts]] :: A pure lisp implementation of TTF font rendering.
|
||||
- [[./util/ttf-fonts/README.txt][ttf-fonts]] :: A pure lisp implementation of TTF font rendering.
|
||||
- [[./util/undocumented/README.org][undocumented]] :: Look for stuff that should probably be in the manual that isn't
|
||||
- [[./util/urgentwindows/README.org][urgentwindows]] :: Allows focusing application windows that need user attention
|
||||
- [[./util/wacom/README.org][wacom]] :: Map StumpWM frames to Wacom tablets using `xsetwacom`.
|
||||
|
|
|
|||
198
util/swm-clim-message/README.org
Normal file
198
util/swm-clim-message/README.org
Normal file
|
|
@ -0,0 +1,198 @@
|
|||
#+TITLE: Clim Based Messaging for StumpWM
|
||||
|
||||
* Usage
|
||||
This module depends upon CLIM, so please ensure it is somewhere that ASDF can
|
||||
find it. If you dont have a copy of CLIM where ASDF can find it, please
|
||||
evaluate ~(ql:quickload :clim)~ at a repl before using this module.
|
||||
|
||||
To load this module, add the following to your stumpwmrc.
|
||||
#+begin_src lisp
|
||||
(load-module "swm-clim-message")
|
||||
#+end_src
|
||||
|
||||
Typical usage is to take a list of objects and pass them to
|
||||
~generate-clim-message~, and then pass the resulting list to ~clim-message~.
|
||||
Here is an example of implementing an analog to ~windowlist~ using
|
||||
~clim-message~. This function is provided as ~swm-clim-message:windowlist~.
|
||||
|
||||
If you write a replacement to a StumpWM command (such as windowlist), please
|
||||
add it to the file =reimplementations.lisp= and open a pull request.
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :stumpwm)
|
||||
|
||||
(defun clim-message-windowlist (&key persist)
|
||||
"Similar to the StumpWM WINDOWLIST command, this lists the windows of the
|
||||
current group, formatted according to STUMPWM:*WINDOW-FORMAT*."
|
||||
(let* ((fmt *window-format*)
|
||||
(group (current-group))
|
||||
(windows (sort-windows-by-number (group-windows group))))
|
||||
(swm-clim-message:clim-message
|
||||
(swm-clim-message:generate-clim-message
|
||||
windows
|
||||
(lambda (w) (format-expand *window-formatters* fmt w))
|
||||
(lambda (w) (group-focus-window group w) w))
|
||||
:repeatable-actions persist
|
||||
:highlight 0
|
||||
:bind-keys t)))
|
||||
#+end_src
|
||||
|
||||
* Functions
|
||||
** Messaging
|
||||
/Function/ *CLIM-MESSAGE, MESSAGE*
|
||||
*Syntax:*
|
||||
*clim-message* /messages/ &key /repeatable-actions screen head highlight bind-keys/ => /frame, process/
|
||||
*message* /things/ &rest /rest/ &key /formatter operator/ => /frame, process/
|
||||
*select-from-menu* /things/ &rest /keys/ => /value/
|
||||
|
||||
*Arguments and Values:*
|
||||
/messages/---a list of conses whose car is a string and whose cdr is a thunk.
|
||||
/repeatable-actions/---a generalized boolean. The default is false.
|
||||
/screen/---a StumpWM screen object.
|
||||
/head/---a StumpWM head object.
|
||||
/highlight/---an integer. The default is -1.
|
||||
/bind-keys/---a generalized boolean. The default is true.
|
||||
/things/---a list of objects.
|
||||
/rest/---a list of keyargs passed to *clim-message*.
|
||||
/formatter/---a function of arity one.
|
||||
/operator/---a function of arity one.
|
||||
/keys/---a list of keyargs passed to *message*.
|
||||
/frame/---a message-window CLIM frame.
|
||||
/process/---a process (thread) object.
|
||||
|
||||
*Description:*
|
||||
|
||||
*message* takes a list of objects and passes it to *generate-clim-message*
|
||||
alongside /formatter/ and /operator/. If /formatter/ is *NIL* the function
|
||||
~(lambda (x) (format nil "~A" x))~ is used. If /operator/ is *NIL* the
|
||||
function ~#'identity~ is used. The resulting list is then passed to
|
||||
*clim-message* alongside all other key arguments.
|
||||
|
||||
All other objects are the same between
|
||||
*message* and *clim-message*.
|
||||
|
||||
*clim-message* displays the car of every cons cell in /messages/ on /screen/
|
||||
and /head/ such that each entry can be selected by either mouse click or
|
||||
keyboard input.
|
||||
|
||||
When /repeatable-actions/ is *T* selection will not close the frame.
|
||||
|
||||
When provided, /highlight/ is the element of messages to display in bold,
|
||||
indexed from zero.
|
||||
|
||||
When /bind-keys/ is *T*, the StumpWM keymap ~*clim-message-window-keymap*~
|
||||
will be activated on running the frame and deactivated when the frame exits.
|
||||
|
||||
The frame being run (/frame/) is returned as the first value, while the
|
||||
process it is running on (/process/) is returned as the second value.
|
||||
|
||||
*Notes:*
|
||||
In this context, frame denotes a CLIM frame, not a StumpWM frame.
|
||||
** Obtain Return Values
|
||||
/Function/ *MESSAGE-WINDOW-CURRENT-VALUE, MESSAGE-WINDOW-FINAL-VALUE*
|
||||
*Syntax:*
|
||||
*message-window-current-value* &key /default timeout wait/ => /result, freshness/
|
||||
*message-window-final-value* &key /process default timeout/ => /result, freshness/
|
||||
|
||||
*Arguments and Values:*
|
||||
/default/---a default return value.
|
||||
/timeout/---an integer, or nil.
|
||||
/wait/---a generalized boolean. The default value is *T*.
|
||||
/process/---a process (thread) object.
|
||||
/result/---the value of the most recently chosen message window entry.
|
||||
/freshness/---a keyword.
|
||||
|
||||
*Description:*
|
||||
|
||||
*message-window-current-value* returns the currently set value of the message
|
||||
window frame. Because the place this is gotten from is a resource shared
|
||||
between processes a mutex is used to ensure reading and writing cannot occur
|
||||
simultaneously. If /wait/ is *T* then this function will wait until the mutex
|
||||
can be aquired or /timeout/ seconds have passed. If the mutex cannot be
|
||||
aquired within /timeout/ seconds /default/ and /freshness/ are returned.
|
||||
|
||||
*message-window-final-value* returns the final value of a given execution of
|
||||
a message window frame. This is done by attempting to join the process
|
||||
/process/, or if none is provided the most recently run process for the
|
||||
message window frame. If the process doesnt finish within /timeout/ seconds
|
||||
/default/ is returned. Likewise, if no message window frame has been created
|
||||
yet and /process/ is *NIL* /default/ and /freshness/ are returned.
|
||||
|
||||
The value /freshness/ is a keyword of either ~:stale~, ~:fresh~, ~:default~,
|
||||
or ~:timeout~. When /result/ has not been retrieved before, /freshness/ is
|
||||
~:fresh~. When /result/ has been retrieved before /freshness/ is ~:stale~. If
|
||||
the attempt timed out due to not aquiring the mutex or the thread not
|
||||
returning within /timeout/ seconds then /freshness/ is ~:timeout~. If there
|
||||
is no message window frame or /process/ is not a process (thread) object then
|
||||
/freshness/ is ~:default~. If /result/ isnt retrieved before the /process/
|
||||
finishes, *message-window-final-value* will always return /freshness/ as
|
||||
~:fresh~.
|
||||
|
||||
** Generate Message Lists
|
||||
/Function/ *GENERATE-CLIM-MESSAGE*
|
||||
*Syntax:*
|
||||
*generate-clim-message* /list-of-objects/ &optional /string-generation-function operation-function/ => /message-list/
|
||||
|
||||
*Arguments and Values:*
|
||||
/list-of-objects/---a list of arbitrary objects.
|
||||
/string-generation-function/---a function of arity one that generates a string from an object.
|
||||
/operation-function/---a function to call with the selected object.
|
||||
/message-list/---a list suitable to pass to ~clim-message~.
|
||||
|
||||
*Description:*
|
||||
|
||||
Loop over each object in /list-of-objects/ collecting a cons cell whose car
|
||||
is the result of calling /string-generation-function/ on the object and whose
|
||||
cdr is a thunk which, when called, will call /operation-function/ on the
|
||||
object.
|
||||
|
||||
The default value of /string-generation-function/ is
|
||||
~(lambda (x) (format nil "~A" x))~.
|
||||
|
||||
The default value of /operation-function/ is a no-op function of arity one.
|
||||
** Execute Frame Commands
|
||||
/Function/ *SWM-CLIM-MESSAGE-COMMAND*
|
||||
/Command/ *"swm-clim-message-command"*
|
||||
*Syntax:*
|
||||
*swm-clim-message-command* /cmd/ => /value/
|
||||
|
||||
*Arguments and Values:*
|
||||
/cmd/---a string.
|
||||
/value/---nil.
|
||||
|
||||
*Description:*
|
||||
|
||||
Read /cmd/ and pass it (unevaluated) to the message-window frame for
|
||||
execution. The available commands are ~(com-select-next)~,
|
||||
~(com-select-prev)~, ~(com-select-choose)~, ~(com-select-choose-and-quit)~,
|
||||
and ~(com-quit)~.
|
||||
|
||||
*Note:*
|
||||
|
||||
Because /cmd/ is not evaluated, the only way to compute values is to use the
|
||||
#. reader macro. Computing values is not advised.
|
||||
* Variables
|
||||
** Keymap
|
||||
/Variable/ **CLIM-MESSAGE-WINDOW-KEYMAP**
|
||||
|
||||
*Value Type:*
|
||||
|
||||
A Stumpwm kmap object.
|
||||
|
||||
*Description:*
|
||||
|
||||
A keymap that is activated when the message window is active. This keymap is
|
||||
used to execute commands within the message window frame by way of
|
||||
/swm-clim-message-command/.
|
||||
|
||||
*Default Bindings:*
|
||||
|
||||
| Key | Command | Description |
|
||||
|-------+----------------------------+----------------------------------------|
|
||||
| C-n | com-select-next | highlight the next entry |
|
||||
| C-p | com-select-prev | highlight the previous entry |
|
||||
| RET | com-select-choose | choose the highlighted entry |
|
||||
| C-RET | com-select-choose-and-quit | call com-select-choose, exit the frame |
|
||||
| ESC | com-quit | exit the frame |
|
||||
| C-g | com-quit | exit the frame |
|
||||
|
||||
14
util/swm-clim-message/package.lisp
Normal file
14
util/swm-clim-message/package.lisp
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
;;;; package.lisp
|
||||
|
||||
(defpackage #:swm-clim-message
|
||||
(:use #:clim #:clim-lisp)
|
||||
(:export #:clim-message
|
||||
#:generate-clim-message
|
||||
#:message
|
||||
#:select-from-menu
|
||||
#:message-window-current-value
|
||||
#:message-window-final-value
|
||||
#:*clim-message-window-keymap*
|
||||
#:swm-clim-message-command
|
||||
#:windowlist
|
||||
#:select-window-from-menu))
|
||||
25
util/swm-clim-message/reimplementations.lisp
Normal file
25
util/swm-clim-message/reimplementations.lisp
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
(in-package :swm-clim-message)
|
||||
|
||||
(defun windowlist (&key persist)
|
||||
"Similar to the StumpWM WINDOWLIST command, this lists the windows of the
|
||||
current group, formatted according to STUMPWM:*WINDOW-FORMAT*."
|
||||
(let* ((fmt stumpwm:*window-format*)
|
||||
(group (stumpwm:current-group))
|
||||
(windows (stumpwm::sort-windows-by-number
|
||||
(stumpwm:group-windows group))))
|
||||
(clim-message
|
||||
(generate-clim-message
|
||||
windows
|
||||
(lambda (w) (stumpwm:format-expand stumpwm:*window-formatters* fmt w))
|
||||
(lambda (w) (stumpwm:group-focus-window group w) w))
|
||||
:repeatable-actions persist
|
||||
:highlight 0
|
||||
:bind-keys t)))
|
||||
|
||||
(defun select-window-from-menu (windows &optional (fmt stumpwm:*window-format*))
|
||||
(select-from-menu windows
|
||||
:formatter (lambda (w)
|
||||
(stumpwm:format-expand stumpwm:*window-formatters*
|
||||
fmt
|
||||
w))
|
||||
:highlight 0))
|
||||
12
util/swm-clim-message/swm-clim-message.asd
Normal file
12
util/swm-clim-message/swm-clim-message.asd
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
;;;; swm-clim-message.asd
|
||||
|
||||
(asdf:defsystem #:swm-clim-message
|
||||
:description "Display StumpWM messages and menus through CLIM"
|
||||
:author "szos (at) posteo (dot) net"
|
||||
:license "GPLv3"
|
||||
:version "0.0.1"
|
||||
:serial t
|
||||
:depends-on (#:stumpwm #:clim #:clim-lisp #:mcclim)
|
||||
:components ((:file "package")
|
||||
(:file "swm-clim-message")
|
||||
(:file "reimplementations")))
|
||||
396
util/swm-clim-message/swm-clim-message.lisp
Normal file
396
util/swm-clim-message/swm-clim-message.lisp
Normal file
|
|
@ -0,0 +1,396 @@
|
|||
;;;; swm-clim-message.lisp
|
||||
|
||||
(in-package #:swm-clim-message)
|
||||
|
||||
(defvar *message-window-frame* nil ; not the same as a stumpwm frame
|
||||
"Only allow one message window to exist at a time.")
|
||||
|
||||
(defvar *clim-message-window-keymap* (stumpwm:make-sparse-keymap)
|
||||
"A keymap for keybindings to get sent from stumpwm to the clim message window")
|
||||
|
||||
(stumpwm:define-key *clim-message-window-keymap* (stumpwm:kbd "C-n")
|
||||
"swm-clim-message-command (com-select-next)")
|
||||
(stumpwm:define-key *clim-message-window-keymap* (stumpwm:kbd "C-p")
|
||||
"swm-clim-message-command (com-select-prev)")
|
||||
(stumpwm:define-key *clim-message-window-keymap* (stumpwm:kbd "RET")
|
||||
"swm-clim-message-command (com-select-choose)")
|
||||
(stumpwm:define-key *clim-message-window-keymap* (stumpwm:kbd "C-RET")
|
||||
"swm-clim-message-command (com-select-choose-and-quit)")
|
||||
(stumpwm:define-key *clim-message-window-keymap* (stumpwm:kbd "ESC")
|
||||
"swm-clim-message-command (com-quit-overwrite)")
|
||||
(stumpwm:define-key *clim-message-window-keymap* (stumpwm:kbd "C-g")
|
||||
"swm-clim-message-command (com-quit-overwrite)")
|
||||
|
||||
;; Evaluate something within the without messaging the result. Use the
|
||||
;; :swm-clim-message package by default
|
||||
(stumpwm:defcommand swm-clim-message-command (cmd) ((:rest "CMD: "))
|
||||
(handler-case
|
||||
(if cmd
|
||||
(let ((*package* (find-package :swm-clim-message)))
|
||||
(execute-frame-command *message-window-frame* (read-from-string cmd)))
|
||||
(throw 'error :abort))
|
||||
(error (c)
|
||||
(stumpwm:err "^B^1*~A" c))))
|
||||
|
||||
;; Calculate the positioning of the window
|
||||
(defun calculate-gravity (screen head gravity width height)
|
||||
(xlib:with-state ((stumpwm:screen-root screen))
|
||||
(let* ((w width)
|
||||
(h height)
|
||||
(head-x (stumpwm::head-x head))
|
||||
(head-y (stumpwm::head-y head))
|
||||
(head-maxx (+ head-x (stumpwm::head-width head)))
|
||||
(head-maxy (+ head-y (stumpwm::head-height head))))
|
||||
(stumpwm::gravity-coords gravity w h head-x head-y head-maxx head-maxy))))
|
||||
|
||||
;; Specifically used for the message window frame. Could be more general, might
|
||||
;; be a generic to do what we want already, but this is good enough for now.
|
||||
(defun move-resize-message-window (frame &optional
|
||||
(pane (find-pane-named frame 'display)))
|
||||
(when pane
|
||||
(with-sheet-medium (medium pane)
|
||||
(let* ((text-style (medium-text-style medium))
|
||||
(line-height (+ (text-style-height text-style medium)
|
||||
(stream-vertical-spacing pane)))
|
||||
(strings (message-window-strings frame))
|
||||
(w 0)
|
||||
(h 0))
|
||||
(loop for (string . ig) in strings
|
||||
with highlight = (message-window-highlight frame)
|
||||
for x from 0
|
||||
for new-width = (stream-string-width
|
||||
pane
|
||||
(concatenate 'string " " string)
|
||||
:text-style (if (= x highlight)
|
||||
(make-text-style (text-style-family
|
||||
text-style)
|
||||
:bold
|
||||
(text-style-size
|
||||
text-style))
|
||||
text-style))
|
||||
do (incf h line-height)
|
||||
(when (> new-width w)
|
||||
(setf w new-width)))
|
||||
(multiple-value-bind (x y)
|
||||
(stumpwm::calculate-gravity (message-window-stumpwm-screen frame)
|
||||
(message-window-stumpwm-head frame)
|
||||
stumpwm:*message-window-gravity*
|
||||
w
|
||||
h)
|
||||
(move-and-resize-sheet (frame-top-level-sheet frame) x y w h))))))
|
||||
|
||||
(defmacro bold ((stream) &body body)
|
||||
`(with-text-face (,stream :bold)
|
||||
,@body))
|
||||
|
||||
;; Define our frame
|
||||
(define-application-frame message-window ()
|
||||
((persistent :initarg :persistent
|
||||
:initform nil
|
||||
:accessor message-window-persistent)
|
||||
(strings :initarg :strings
|
||||
:accessor message-window-strings)
|
||||
(highlight :initarg :highlight
|
||||
:initform -1
|
||||
:accessor message-window-highlight)
|
||||
(proc :accessor message-window-process)
|
||||
(stumpwm-screen :initarg :screen
|
||||
:initform (stumpwm:current-screen)
|
||||
:accessor message-window-stumpwm-screen)
|
||||
(stumpwm-head :initarg :head
|
||||
:initform (stumpwm:current-head)
|
||||
:accessor message-window-stumpwm-head)
|
||||
(return-value :initform (cons nil nil)
|
||||
:initarg :default-return-value)
|
||||
(mutex :initform (sb-thread:make-mutex :name "message-window-mutex")
|
||||
:accessor message-window-frame-mutex))
|
||||
(:panes (display :application
|
||||
:display-function 'display-message-window
|
||||
:scroll-bars nil
|
||||
:background +black+
|
||||
:foreground +white+))
|
||||
(:layouts (default display)))
|
||||
|
||||
;; We dont want this to be treated as a regular window.
|
||||
(defmethod clim-extensions:find-frame-type ((frame message-window))
|
||||
:override-redirect)
|
||||
|
||||
;; We need to redisplay when we change a slot that impacts behavior. So for
|
||||
;; example when we change the strings we need to redisplay so that the new
|
||||
;; strings are displayed. when we change the persistance we need to redisplay so
|
||||
;; that the strings are displayed with the correct presentation to command
|
||||
;; translator.
|
||||
(defmethod (setf message-window-strings) :after (new (frame message-window))
|
||||
(declare (ignore new))
|
||||
(redisplay-frame-panes frame :force-p t))
|
||||
|
||||
(defmethod (setf message-window-persistent) :after (new (frame message-window))
|
||||
(declare (ignore new))
|
||||
(redisplay-frame-panes frame :force-p t))
|
||||
|
||||
(defmethod (setf message-window-stumpwm-screen) :after (new (frame message-window))
|
||||
(move-resize-message-window frame))
|
||||
|
||||
(defmethod (setf message-window-stumpwm-head) :after (new (frame message-window))
|
||||
(move-resize-message-window frame))
|
||||
|
||||
(defgeneric message-window-return (frame &key wait timeout default))
|
||||
|
||||
(defmethod message-window-return ((frame message-window) &key wait timeout default)
|
||||
(multiple-value-call
|
||||
(lambda (&optional (return-value) (state :failure) &rest rest)
|
||||
(declare (ignore rest))
|
||||
(if (eql state :failure)
|
||||
(values default :timeout)
|
||||
(values return-value state)))
|
||||
(sb-thread:with-mutex ((message-window-frame-mutex frame) :wait-p wait
|
||||
:timeout timeout)
|
||||
(let* ((cell (slot-value frame 'return-value))
|
||||
(gotten (cdr cell)))
|
||||
(setf (cdr cell) :stale)
|
||||
(values (car cell)
|
||||
gotten)))))
|
||||
|
||||
(defmethod (setf message-window-return) (new (frame message-window))
|
||||
(sb-thread:with-mutex ((message-window-frame-mutex frame) :wait-p t)
|
||||
(let ((cell (slot-value frame 'return-value)))
|
||||
(setf (cdr cell) :fresh
|
||||
(car cell) new))))
|
||||
|
||||
;;;;;;;;;;;;;;;;
|
||||
;;; COMMANDS ;;;
|
||||
;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Commands and their presentation types & translators
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
;; Quit The Frame ;;
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-message-window-command (com-quit :name t)
|
||||
()
|
||||
(frame-exit *application-frame*))
|
||||
|
||||
(define-message-window-command (com-quit-overwrite :name t)
|
||||
()
|
||||
(setf (message-window-return *application-frame*) nil)
|
||||
(com-quit))
|
||||
|
||||
(define-presentation-type close-message-window ())
|
||||
(define-presentation-to-command-translator close-mw
|
||||
(close-message-window com-quit message-window :gesture :select)
|
||||
(txt)
|
||||
nil)
|
||||
|
||||
;;;;;;;;;;;;;;;;
|
||||
;; Selections ;;
|
||||
;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-message-window-command (com-select-next :name t)
|
||||
()
|
||||
(setf (message-window-highlight *application-frame*)
|
||||
(if (= (message-window-highlight *application-frame*)
|
||||
(1- (length (message-window-strings *application-frame*))))
|
||||
0
|
||||
(1+ (message-window-highlight *application-frame*)))))
|
||||
|
||||
(define-message-window-command (com-select-prev :name t)
|
||||
()
|
||||
(setf (message-window-highlight *application-frame*)
|
||||
(if (= (message-window-highlight *application-frame*) 0)
|
||||
(1- (length (message-window-strings *application-frame*)))
|
||||
(1- (message-window-highlight *application-frame*)))))
|
||||
|
||||
(define-message-window-command (com-select-choose :name t)
|
||||
()
|
||||
(let ((selection (elt (message-window-strings *application-frame*)
|
||||
(message-window-highlight *application-frame*))))
|
||||
(if (message-window-persistent *application-frame*)
|
||||
(com-call-thunk (cdr selection))
|
||||
(com-call-thunk-and-exit (cdr selection)))))
|
||||
|
||||
(define-message-window-command (com-select-choose-and-quit :name t)
|
||||
()
|
||||
(let ((selection (elt (message-window-strings *application-frame*)
|
||||
(message-window-highlight *application-frame*))))
|
||||
(com-call-thunk-and-exit (cdr selection))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;
|
||||
;; Call Thunks ;;
|
||||
;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-message-window-command (com-call-thunk :name t)
|
||||
((thunk function))
|
||||
(setf (message-window-return *application-frame*) (funcall thunk)))
|
||||
|
||||
(define-message-window-command (com-call-thunk-and-exit :name t)
|
||||
((thunk function))
|
||||
(com-call-thunk thunk)
|
||||
(com-quit))
|
||||
|
||||
(define-presentation-type evaluate-entry ())
|
||||
(define-presentation-to-command-translator eventry
|
||||
(evaluate-entry com-call-thunk message-window
|
||||
:gesture :select
|
||||
:priority 1
|
||||
:documentation "Evaluate Entry")
|
||||
(thnk)
|
||||
(list thnk))
|
||||
|
||||
(define-presentation-to-command-translator eventry-and-quit
|
||||
(evaluate-entry com-call-thunk-and-exit message-window
|
||||
:gesture :select
|
||||
:priority 9
|
||||
:documentation "Evaluate Entry And Quit")
|
||||
(thnk)
|
||||
(list thnk))
|
||||
|
||||
(define-presentation-type evaluate-entry-persist ())
|
||||
(define-presentation-to-command-translator eventry-p
|
||||
(evaluate-entry-persist com-call-thunk message-window
|
||||
:gesture :select
|
||||
:priority 1
|
||||
:documentation "Evaluate Entry")
|
||||
(thnk)
|
||||
(list thnk))
|
||||
|
||||
(define-presentation-to-command-translator eventry-and-quit-p
|
||||
(evaluate-entry-persist com-call-thunk-and-exit message-window
|
||||
:gesture :select
|
||||
:priority 0
|
||||
:documentation "Evaluate Entry And Quit")
|
||||
(thnk)
|
||||
(list thnk))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Display Function ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun display-message-window (frame pane)
|
||||
(with-sheet-medium (medium pane)
|
||||
(move-resize-message-window frame pane)
|
||||
(loop for x from 0
|
||||
for string in (message-window-strings frame)
|
||||
with highlight = (message-window-highlight frame)
|
||||
do (with-output-as-presentation
|
||||
(pane (cdr string) (if (message-window-persistent frame)
|
||||
'evaluate-entry-persist
|
||||
'evaluate-entry))
|
||||
(if (= x highlight)
|
||||
(bold (pane)
|
||||
(format pane "~&~A~%" (car string)))
|
||||
(format pane "~&~A~%" (car string)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Messaging Function ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun clim-message (messages &key repeatable-actions
|
||||
(screen (stumpwm:current-screen))
|
||||
(head (stumpwm:current-head))
|
||||
(highlight -1)
|
||||
(bind-keys t))
|
||||
"Run a message-window frame, with the string list provided, "
|
||||
(let ((frame (or *message-window-frame*
|
||||
(make-application-frame 'message-window)))
|
||||
(thread-name (format nil "Message-Window-~A" (gensym))))
|
||||
(unless *message-window-frame*
|
||||
(setf *message-window-frame* frame))
|
||||
(macrolet ((set-slot (slot thing)
|
||||
`(setf (slot-value frame ,slot) ,thing)))
|
||||
(set-slot 'strings messages)
|
||||
(set-slot 'persistent repeatable-actions)
|
||||
(set-slot 'stumpwm-screen screen)
|
||||
(set-slot 'stumpwm-head head)
|
||||
(set-slot 'highlight highlight))
|
||||
(setf (message-window-process frame)
|
||||
(sb-thread:make-thread
|
||||
(lambda ()
|
||||
(block message-process-block
|
||||
(unwind-protect
|
||||
(progn (when bind-keys
|
||||
(stumpwm::push-top-map *clim-message-window-keymap*))
|
||||
(run-frame-top-level frame)
|
||||
(return-from message-process-block
|
||||
(message-window-return frame)))
|
||||
(when bind-keys
|
||||
(stumpwm::pop-top-map)))))
|
||||
:name thread-name))
|
||||
(values frame
|
||||
(message-window-process frame))))
|
||||
|
||||
(defun generate-clim-message (list-of-objects &optional
|
||||
(string-generation-function
|
||||
(lambda (x) (format nil "~A" x)))
|
||||
(operation-function #'identity))
|
||||
"Take a list of objects and generate a list suitable for passing to
|
||||
clim-message.
|
||||
|
||||
LIST-OF-OBJECTS must be a list of objects you wish to act upon.
|
||||
|
||||
STRING-GENERATION-FUNCTION must be a function of arity one that returns a
|
||||
string. It will be called once on every object. By default this is a function
|
||||
that pretty prints the object to a string via formats ~A directive. These
|
||||
strings are used to display the object.
|
||||
|
||||
OPERATION-FUNCTION must be a function of arity one that operates upon the
|
||||
object. This will be passed further along to the clim message object, and when
|
||||
an object is selected, it will be called with that object. By default this is a
|
||||
function that ignores its argument and returns nil.
|
||||
|
||||
Example:
|
||||
|
||||
(generate-clim-message
|
||||
windows ; from stumpwm
|
||||
(lambda (w) (stumpwm:format-expand stumpwm:*window-formatters* fmt w))
|
||||
(lambda (w) (stumpwm:group-focus-window group w)))
|
||||
|
||||
will construct a list of conses, where each cons' car is a string generated from
|
||||
stumpwm:format-expand, and its cdr is is a thunk which will call the provided
|
||||
function with the appropriate window."
|
||||
(do ((ls list-of-objects (cdr ls))
|
||||
(head nil)
|
||||
(tail nil))
|
||||
((null ls) head)
|
||||
(let ((newcdr (list (cons (funcall string-generation-function (car ls))
|
||||
(let ((el (car ls)))
|
||||
(lambda ()
|
||||
(funcall operation-function el)))))))
|
||||
(if head
|
||||
(setf (cdr tail) newcdr
|
||||
tail (cdr tail))
|
||||
(setf head newcdr
|
||||
tail head)))))
|
||||
|
||||
(defun message (things &rest rest &key formatter operator &allow-other-keys)
|
||||
"Display things as formatted by FORMATTER using clim-message. Return the
|
||||
object returned by OPERATOR."
|
||||
(remf rest :formatter)
|
||||
(remf rest :operator)
|
||||
(apply #'clim-message
|
||||
(generate-clim-message things
|
||||
(or formatter (lambda (x) (format nil "~A" x)))
|
||||
(or operator #'identity))
|
||||
rest))
|
||||
|
||||
(defun message-window-current-value (&key default timeout (wait t))
|
||||
(if *message-window-frame*
|
||||
(message-window-return *message-window-frame* :wait wait
|
||||
:timeout timeout
|
||||
:default default)
|
||||
(values default :default)))
|
||||
|
||||
(defun message-window-final-value (&key process
|
||||
default timeout)
|
||||
(let ((proc (or process
|
||||
(and *message-window-frame*
|
||||
(message-window-process *message-window-frame*)))))
|
||||
(if (and proc (typep proc 'sb-thread:thread))
|
||||
(sb-thread:join-thread proc :default default :timeout timeout)
|
||||
(values default :default))))
|
||||
|
||||
(defun select-from-menu (things &rest keys)
|
||||
(multiple-value-bind (frame process)
|
||||
(apply #'message things keys)
|
||||
(declare (ignore frame))
|
||||
(message-window-final-value :process process)))
|
||||
Loading…
Reference in a new issue