src/clfswm-info.lisp (show-config-variable); src/clfswm-autodoc.lisp (produce-configu...
[clfswm.git] / src / clfswm-info.lisp
blob9520d72c9f2993a2f5ea78c19a716e2314619ce7
1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
3 ;;;
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Info function (see the end of this file for user definition
6 ;;; --------------------------------------------------------------------------
7 ;;;
8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
9 ;;;
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
14 ;;;
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 ;;;
24 ;;; --------------------------------------------------------------------------
26 (in-package :clfswm)
28 (defstruct info window gc font list ilw ilh x y max-x max-y)
31 (defparameter *info-selected-item* nil)
34 (defun leave-info-mode (info)
35 "Leave the info mode"
36 (declare (ignore info))
37 (setf *info-selected-item* nil)
38 (throw 'exit-info-loop nil))
40 (defun leave-info-mode-and-valid (info)
41 "Leave the info mode and valid the selected item"
42 (declare (ignore info))
43 (throw 'exit-info-loop nil))
45 (defun mouse-leave-info-mode (window root-x root-y info)
46 "Leave the info mode"
47 (declare (ignore window root-x root-y info))
48 (setf *info-selected-item* nil)
49 (throw 'exit-info-loop nil))
53 (defun find-info-item-from-mouse (root-x root-y info)
54 (if (< (xlib:drawable-x (info-window info)) root-x
55 (+ (xlib:drawable-x (info-window info))
56 (xlib:drawable-width (info-window info))))
57 (truncate (/ (- (+ (- root-y (xlib:drawable-y (info-window info)))
58 (xlib:max-char-ascent (info-font info))
59 (info-y info)) (info-ilh info)) (info-ilh info)))
60 nil))
63 (defun set-info-item-form-mouse (root-x root-y info)
64 (setf *info-selected-item* (find-info-item-from-mouse root-x root-y info)))
67 (defun info-y-display-coords (info posy)
68 (- (+ (* (info-ilh info) posy) (info-ilh info)) (info-y info)))
70 (defun incf-info-selected-item (info n)
71 (setf *info-selected-item*
72 (min (if *info-selected-item*
73 (+ *info-selected-item* n)
75 (1- (or (length (info-list info)) 1)))))
77 (defun decf-info-selected-item (info n)
78 (declare (ignore info))
79 (setf *info-selected-item*
80 (max (if *info-selected-item*
81 (- *info-selected-item* n)
83 0)))
87 (defun draw-info-window (info)
88 (labels ((print-line (line posx posy &optional (color *info-foreground*))
89 (xlib:with-gcontext ((info-gc info) :foreground (get-color color)
90 :background (if (equal posy *info-selected-item*)
91 (get-color *info-selected-background*)
92 (get-color *info-background*)))
93 (xlib:draw-image-glyphs *pixmap-buffer* (info-gc info)
94 (- (+ (info-ilw info) (* posx (info-ilw info))) (info-x info))
95 (info-y-display-coords info posy)
96 (format nil "~A" line)))
97 (+ posx (length line))))
98 (clear-pixmap-buffer (info-window info) (info-gc info))
99 (loop for line in (info-list info)
100 for y from 0
101 do (typecase line
102 (cons (typecase (first line)
103 (cons (let ((posx 0))
104 (dolist (l line)
105 (typecase l
106 (cons (setf posx (print-line (first l) posx y (second l))))
107 (t (setf posx (print-line l posx y)))))))
108 (t (print-line (first line) 0 y (second line)))))
109 (t (print-line line 0 y))))
110 (copy-pixmap-buffer (info-window info) (info-gc info))))
116 ;;;,-----
117 ;;;| Key binding
118 ;;;`-----
120 (add-hook *binding-hook* 'init-*info-keys* 'init-*info-mouse*)
122 (defun set-default-info-keys ()
123 (define-info-key (#\q) 'leave-info-mode)
124 (define-info-key ("Return") 'leave-info-mode-and-valid)
125 (define-info-key ("space") 'leave-info-mode-and-valid)
126 (define-info-key ("Escape") 'leave-info-mode)
127 (define-info-key ("g" :control) 'leave-info-mode)
128 (define-info-key ("twosuperior")
129 (defun info-banish-pointer (info)
130 "Move the pointer to the lower right corner of the screen"
131 (declare (ignore info))
132 (banish-pointer)))
133 (define-info-key ("Down")
134 (defun info-next-line (info)
135 "Move one line down"
136 (incf-info-selected-item info 1)
137 (when (> (info-y-display-coords info *info-selected-item*)
138 (+ (xlib:drawable-y (info-window info))
139 (xlib:drawable-height (info-window info))))
140 (setf (info-y info) (min (+ (info-y info) (info-ilh info)) (info-max-y info))))
141 (draw-info-window info)))
142 (define-info-key ("Up")
143 (defun info-previous-line (info)
144 "Move one line up"
145 (decf-info-selected-item info 1)
146 (when (< (info-y-display-coords info *info-selected-item*)
147 (+ (xlib:drawable-y (info-window info))
148 (info-ilh info)))
149 (setf (info-y info) (max (- (info-y info) (info-ilh info)) 0)))
150 (draw-info-window info)))
151 (define-info-key ("Left")
152 (defun info-previous-char (info)
153 "Move one char left"
154 (setf (info-x info) (max (- (info-x info) (info-ilw info)) 0))
155 (draw-info-window info)))
156 (define-info-key ("Right")
157 (defun info-next-char (info)
158 "Move one char right"
159 (setf (info-x info) (min (+ (info-x info) (info-ilw info)) (info-max-x info)))
160 (draw-info-window info)))
161 (define-info-key ("Home")
162 (defun info-first-line (info)
163 "Move to first line"
164 (setf (info-x info) 0
165 (info-y info) 0)
166 (setf *info-selected-item* 0)
167 (draw-info-window info)))
168 (define-info-key ("End")
169 (defun info-end-line (info)
170 "Move to last line"
171 (setf (info-x info) 0
172 (info-y info) (- (* (length (info-list info)) (info-ilh info)) (xlib:drawable-height (info-window info))))
173 (setf *info-selected-item* (1- (or (length (info-list info)) 1)))
174 (draw-info-window info)))
175 (define-info-key ("Page_Down")
176 (defun info-next-ten-lines (info)
177 "Move ten lines down"
178 (incf-info-selected-item info 10)
179 (when (> (info-y-display-coords info *info-selected-item*)
180 (+ (xlib:drawable-y (info-window info))
181 (xlib:drawable-height (info-window info))))
182 (setf (info-y info) (min (+ (info-y info) (* (info-ilh info) 10)) (info-max-y info))))
183 (draw-info-window info)))
184 (define-info-key ("Page_Up")
185 (defun info-previous-ten-lines (info)
186 "Move ten lines up"
187 (decf-info-selected-item info 10)
188 (when (< (info-y-display-coords info *info-selected-item*)
189 (+ (xlib:drawable-y (info-window info))
190 (info-ilh info)))
191 (setf (info-y info) (max (- (info-y info) (* (info-ilh info) 10)) 0)))
192 (draw-info-window info))))
194 (add-hook *binding-hook* 'set-default-info-keys)
199 (defparameter *info-start-grab-x* nil)
200 (defparameter *info-start-grab-y* nil)
203 (defun info-begin-grab (window root-x root-y info)
204 "Begin grab text"
205 (declare (ignore window))
206 (setf *info-start-grab-x* (min (max (+ root-x (info-x info)) 0) (info-max-x info))
207 *info-start-grab-y* (min (max (+ root-y (info-y info)) 0) (info-max-y info)))
208 (draw-info-window info))
210 (defun info-end-grab (window root-x root-y info)
211 "End grab"
212 (declare (ignore window))
213 (setf (info-x info) (min (max (- *info-start-grab-x* root-x) 0) (info-max-x info))
214 (info-y info) (min (max (- *info-start-grab-y* root-y) 0) (info-max-y info))
215 *info-start-grab-x* nil
216 *info-start-grab-y* nil)
217 (draw-info-window info))
219 (defun info-mouse-next-line (window root-x root-y info)
220 "Move one line down"
221 (declare (ignore window))
222 (setf (info-y info) (min (+ (info-y info) (info-ilh info)) (info-max-y info)))
223 (set-info-item-form-mouse root-x root-y info)
224 (draw-info-window info))
226 (defun info-mouse-previous-line (window root-x root-y info)
227 "Move one line up"
228 (declare (ignore window))
229 (setf (info-y info) (max (- (info-y info) (info-ilh info)) 0))
230 (set-info-item-form-mouse root-x root-y info)
231 (draw-info-window info))
234 (defun info-mouse-motion-drag (window root-x root-y info)
235 "Grab text"
236 (declare (ignore window))
237 (when (and *info-start-grab-x* *info-start-grab-y*)
238 (setf (info-x info) (min (max (- *info-start-grab-x* root-x) 0) (info-max-x info))
239 (info-y info) (min (max (- *info-start-grab-y* root-y) 0) (info-max-y info)))
240 (draw-info-window info)))
248 (defun info-mouse-select-item (window root-x root-y info)
249 (declare (ignore window))
250 (set-info-item-form-mouse root-x root-y info)
251 (leave-info-mode-and-valid info))
253 (defun info-mouse-motion-click (window root-x root-y info)
254 (declare (ignore window))
255 (let ((last *info-selected-item*))
256 (set-info-item-form-mouse root-x root-y info)
257 (unless (equal last *info-selected-item*)
258 (draw-info-window info))))
262 (defun set-default-info-mouse ()
263 (if *info-click-to-select*
264 (define-info-mouse (1) nil 'info-mouse-select-item)
265 (define-info-mouse (1) 'info-begin-grab 'info-end-grab))
266 (define-info-mouse (2) 'mouse-leave-info-mode)
267 (define-info-mouse (3) 'mouse-leave-info-mode)
268 (define-info-mouse (4) 'info-mouse-previous-line)
269 (define-info-mouse (5) 'info-mouse-next-line)
270 (if *info-click-to-select*
271 (define-info-mouse ('motion) 'info-mouse-motion-click nil)
272 (define-info-mouse ('motion) 'info-mouse-motion-drag nil)))
274 (add-hook *binding-hook* 'set-default-info-mouse)
278 (let (info)
279 (define-handler info-mode :key-press (code state)
280 (funcall-key-from-code *info-keys* code state info))
282 (define-handler info-mode :motion-notify (window root-x root-y)
283 (unless (compress-motion-notify)
284 (funcall-button-from-code *info-mouse* 'motion (modifiers->state *default-modifiers*)
285 window root-x root-y *fun-press* (list info))))
287 (define-handler info-mode :button-press (window root-x root-y code state)
288 (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info)))
290 (define-handler info-mode :button-release (window root-x root-y code state)
291 (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info)))
295 (defun info-mode (info-list &key (width nil) (height nil))
296 "Open the info mode. Info-list is a list of info: One string per line
297 Or for colored output: a list (line_string color)
298 Or ((1_word color) (2_word color) 3_word (4_word color)...)"
299 (when info-list
300 (setf *info-selected-item* 0)
301 (labels ((compute-size (line)
302 (typecase line
303 (cons (typecase (first line)
304 (cons (let ((val 0))
305 (dolist (l line val)
306 (incf val (typecase l
307 (cons (length (first l)))
308 (t (length l)))))))
309 (t (length (first line)))))
310 (t (length line)))))
311 (let* ((font (xlib:open-font *display* *info-font-string*))
312 (ilw (xlib:max-char-width font))
313 (ilh (+ (xlib:max-char-ascent font) (xlib:max-char-descent font) 1))
314 (width (or width
315 (min (* (+ (loop for l in info-list maximize (compute-size l)) 2) ilw)
316 (xlib:screen-width *screen*))))
317 (height (or height
318 (min (round (+ (* (length info-list) ilh) (/ ilh 2)))
319 (xlib:screen-height *screen*)))))
320 (with-placement (*info-mode-placement* x y width height)
321 (let* ((pointer-grabbed-p (xgrab-pointer-p))
322 (keyboard-grabbed-p (xgrab-keyboard-p))
323 (window (xlib:create-window :parent *root*
324 :x x :y y
325 :width width
326 :height height
327 :background (get-color *info-background*)
328 :colormap (xlib:screen-default-colormap *screen*)
329 :border-width 1
330 :border (get-color *info-border*)
331 :event-mask '(:exposure)))
332 (gc (xlib:create-gcontext :drawable window
333 :foreground (get-color *info-foreground*)
334 :background (get-color *info-background*)
335 :font font
336 :line-style :solid)))
337 (setf info (make-info :window window :gc gc :x 0 :y 0 :list info-list
338 :font font :ilw ilw :ilh ilh
339 :max-x (* (loop for l in info-list maximize (compute-size l)) ilw)
340 :max-y (* (length info-list) ilh)))
341 (map-window window)
342 (draw-info-window info)
343 (xgrab-pointer *root* 68 69)
344 (unless keyboard-grabbed-p
345 (xgrab-keyboard *root*))
346 (wait-no-key-or-button-press)
347 (generic-mode 'info-mode 'exit-info-loop
348 :loop-function (lambda ()
349 (raise-window (info-window info)))
350 :original-mode '(main-mode))
351 (if pointer-grabbed-p
352 (xgrab-pointer *root* 66 67)
353 (xungrab-pointer))
354 (unless keyboard-grabbed-p
355 (xungrab-keyboard))
356 (xlib:free-gcontext gc)
357 (xlib:destroy-window window)
358 (xlib:close-font font)
359 (xlib:display-finish-output *display*)
360 (display-all-frame-info)
361 (wait-no-key-or-button-press)
362 *info-selected-item*)))))))
366 (defun info-mode-menu (item-list &key (width nil) (height nil))
367 "Open an info help menu.
368 Item-list is: '((key function) separator (key function))
369 or with explicit docstring: '((key function \"documentation 1\") (key function \"bla bla\") (key function))
370 key is a character, a keycode or a keysym
371 Separator is a string or a symbol (all but a list)
372 Function can be a function or a list (function color) for colored output"
373 (let ((info-list nil)
374 (action nil))
375 (labels ((define-key (key function)
376 (define-info-key-fun (list key)
377 (lambda (&optional args)
378 (declare (ignore args))
379 (setf action function)
380 (leave-info-mode nil)))))
381 (dolist (item item-list)
382 (typecase item
383 (cons (destructuring-bind (key function explicit-doc) (ensure-n-elems item 3)
384 (typecase function
385 (cons (push (list (list (format nil "~A" key) *menu-color-menu-key*)
386 (list (format nil ": ~A" (or explicit-doc (documentation (first function) 'function)))
387 (second function)))
388 info-list)
389 (define-key key (first function)))
390 (t (push (list (list (format nil "~A" key) *menu-color-key*)
391 (format nil ": ~A" (or explicit-doc (documentation function 'function))))
392 info-list)
393 (define-key key function)))))
394 (t (push (list (format nil "-=- ~A -=-" item) *menu-color-comment*) info-list))))
395 (let ((selected-item (info-mode (nreverse info-list) :width width :height height)))
396 (dolist (item item-list)
397 (when (consp item)
398 (let ((key (first item)))
399 (undefine-info-key-fun (list key)))))
400 (when selected-item
401 (awhen (nth selected-item item-list)
402 (when (consp it)
403 (destructuring-bind (key function explicit-doc) (ensure-n-elems it 3)
404 (declare (ignore key explicit-doc))
405 (typecase function
406 (cons (setf action (first function)))
407 (t (setf action function)))))))
408 (typecase action
409 (function (funcall action))
410 (symbol (when (fboundp action)
411 (funcall action))))))))
417 (defun keys-from-list (list)
418 "Produce a key menu based on list item"
419 (loop for l in list
420 for i from 0
421 collect (list (number->char i) l)))
424 ;;;,-----
425 ;;;| CONFIG - Info mode functions
426 ;;;`-----
427 (defun key-binding-colorize-line (list)
428 (loop :for line :in list
429 :collect (cond ((search "* CLFSWM Keys *" line) (list line *info-color-title*))
430 ((search "---" line) (list line *info-color-underline*))
431 ((begin-with-2-spaces line)
432 (list (list (subseq line 0 22) *info-color-second*)
433 (list (subseq line 22 35) *info-color-first*)
434 (subseq line 35)))
435 (t line))))
438 (defun show-key-binding (&rest hash-table-key)
439 "Show the binding of each hash-table-key.
440 Pass the :no-producing-doc symbol to remove the producing doc"
441 (info-mode (key-binding-colorize-line
442 (split-string (append-newline-space
443 (with-output-to-string (stream)
444 (produce-doc (remove :no-producing-doc hash-table-key)
445 stream
446 (not (member :no-producing-doc hash-table-key)))))
447 #\Newline))))
450 (defun show-global-key-binding ()
451 "Show all key binding"
452 (show-key-binding *main-keys* *main-mouse* *second-keys* *second-mouse*
453 *info-keys* *info-mouse*))
455 (defun show-main-mode-key-binding ()
456 "Show the main mode binding"
457 (show-key-binding *main-keys* *main-mouse*))
459 (defun show-second-mode-key-binding ()
460 "Show the second mode key binding"
461 (show-key-binding *second-keys* *second-mouse*))
463 (defun show-circulate-mode-key-binding ()
464 "Show the circulate mode key binding"
465 (show-key-binding *circulate-keys*))
467 (defun show-expose-window-mode-key-binding ()
468 "Show the expose window mode key binding"
469 (show-key-binding *expose-keys* *expose-mouse*))
472 (defun show-first-aid-kit ()
473 "Show the first aid kit key binding"
474 (labels ((add-key (hash symbol &optional (hashkey *main-keys*))
475 (multiple-value-bind (k v)
476 (find-in-hash symbol hashkey)
477 (setf (gethash k hash) v))))
478 (let ((hash (make-hash-table :test #'equal))
479 (hash-second (make-hash-table :test #'equal)))
480 (setf (gethash 'name hash) "First aid kit - Main mode key binding"
481 (gethash 'name hash-second) "First aid kit - Second mode key binding")
482 (add-key hash 'select-next-child)
483 (add-key hash 'select-previous-child)
484 (add-key hash 'select-next-brother)
485 (add-key hash 'select-previous-brother)
486 (add-key hash 'select-previous-level)
487 (add-key hash 'select-next-level)
488 (add-key hash 'enter-frame)
489 (add-key hash 'leave-frame)
490 (add-key hash 'second-key-mode)
491 (add-key hash 'expose-windows-mode)
492 (add-key hash 'expose-all-windows-mode)
493 (add-key hash 'present-clfswm-terminal)
494 (add-key hash-second 'leave-second-mode *second-keys*)
495 (add-key hash-second 'open-menu *second-keys*)
496 (add-key hash-second 'run-program-from-query-string *second-keys*)
497 (add-key hash-second 'eval-from-query-string *second-keys*)
498 (add-key hash-second 'set-open-in-new-frame-in-parent-frame-nw-hook *second-keys*)
499 (add-key hash-second 'b-start-xterm *second-keys*)
500 (add-key hash-second 'b-start-emacs *second-keys*)
501 (show-key-binding hash hash-second :no-producing-doc))))
504 (defun corner-help-colorize-line (list)
505 (loop :for line :in list
506 :collect (cond ((search "CLFSWM:" line) (list line *info-color-title*))
507 ((search "*:" line) (list line *info-color-underline*))
508 ((begin-with-2-spaces line)
509 (let ((pos (position #\: line)))
510 (if pos
511 (list (list (subseq line 0 (1+ pos)) *info-color-first*)
512 (subseq line (1+ pos)))
513 line)))
514 (t line))))
516 (defun show-corner-help ()
517 "Help on clfswm corner"
518 (info-mode (corner-help-colorize-line
519 (split-string (append-newline-space
520 (with-output-to-string (stream)
521 (produce-corner-doc stream)))
522 #\Newline))))
525 (defun configuration-variable-colorize-line (list)
526 (loop :for line :in list
527 :collect (cond ((search "CLFSWM " line) (list line *info-color-title*))
528 ((search "* =" line)
529 (let ((pos (position #\= line)))
530 (list (list (subseq line 0 (1+ pos)) *info-color-first*)
531 (list (subseq line (1+ pos)) *info-color-second*))))
532 ((search "<=" line) (list line *info-color-underline*))
533 (t line))))
536 (defun show-config-variable ()
537 "Show all configurable variables"
538 (let ((all-groups nil)
539 (result nil))
540 (maphash (lambda (key val)
541 (declare (ignore key))
542 (pushnew (configvar-group val) all-groups :test #'equal))
543 *config-var-table*)
544 (labels ((rec ()
545 (setf result nil)
546 (info-mode-menu (loop :for group :in all-groups
547 :for i :from 0
548 :collect (list (number->char i)
549 (let ((group group))
550 (lambda ()
551 (setf result group)))
552 (config-group->string group))))
553 (when result
554 (info-mode (configuration-variable-colorize-line
555 (split-string (append-newline-space
556 (with-output-to-string (stream)
557 (produce-configuration-variables stream result)))
558 #\Newline)))
559 (rec))))
560 (rec))))
565 (defun show-date ()
566 "Show the current time and date"
567 (info-mode (list (list `("Current date:" ,*menu-color-comment*) (date-string)))))
574 (defun info-on-shell (msg program)
575 (let ((lines (do-shell program nil t)))
576 (info-mode (append (list (list msg *menu-color-comment*))
577 (loop for line = (read-line lines nil nil)
578 while line
579 collect line)))))
583 (defun show-cpu-proc ()
584 "Show current processes sorted by CPU usage"
585 (info-on-shell "Current processes sorted by CPU usage:"
586 "ps --cols=1000 --sort='-%cpu,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
588 (defun show-mem-proc ()
589 "Show current processes sorted by memory usage"
590 (info-on-shell "Current processes sorted by MEMORY usage:"
591 "ps --cols=1000 --sort='-vsz,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
594 (defun show-cd-info ()
595 "Show the current CD track"
596 (info-on-shell "Current CD track:" "pcd i"))
598 (defun show-cd-playlist ()
599 "Show the current CD playlist"
600 (info-on-shell "Current CD playlist:" "pcd mi"))
603 (defun show-version ()
604 "Show the current CLFSWM version"
605 (info-mode (list *version*)))