Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

534 lines (452 sloc) 20.922 kb
;; Copyright (C) 2006-2008 Shawn Betts
;;
;; This file is part of stumpwm.
;;
;; stumpwm 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 2, or (at your option)
;; any later version.
;; stumpwm 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 software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
(in-package :stumpwm)
(export '(*mode-line-background-color*
*mode-line-border-color*
*mode-line-border-width*
*mode-line-foreground-color*
*mode-line-pad-x*
*mode-line-pad-y*
*mode-line-position*
*mode-line-timeout*
*hidden-window-color*
*screen-mode-line-format*
*screen-mode-line-formatters*
add-screen-mode-line-formatter
enable-mode-line
toggle-mode-line
bar-zone-color))
(defstruct mode-line
screen
head
window
format
position
contents
cc
height
factor
cubes
(mode :stump))
(defun mode-line-gc (ml)
(ccontext-gc (mode-line-cc ml)))
(defvar *mode-line-position* :top
"Specifies where the mode line is displayed. Valid values are :top and :bottom.")
(defvar *mode-line-border-width* 1
"Specifies how thick the mode line's border will be. Integer value.")
(defvar *mode-line-pad-x* 5
"Specifies the number of padding pixels between the text and the side of the mode line. Integer value.")
(defvar *mode-line-pad-y* 1
"The number of padding pixels between the modeline text and the top/bottom of the modeline? Integer value.")
(defvar *mode-line-background-color* "Gray20"
"The mode line background color.")
(defvar *mode-line-foreground-color* "Gray50"
"The mode line foreground color.")
(defvar *mode-line-border-color* "Gray30"
"The mode line border color.")
(defvar *hidden-window-color* "^5*"
"Color command for hidden windows when using the
fmt-head-window-list-hidden-windows formatter. To disable coloring
hidden windows, set this to an empty string.")
(defvar *screen-mode-line-format* "[^B%n^b] %W"
"This variable describes what will be displayed on the modeline for each screen.
Turn it on with the function TOGGLE-MODE-LINE or the mode-line command.
It is a list where each element may be a string, a symbol, or a list.
For a symbol its value is used.
For a list of the form (:eval FORM) FORM is evaluated and the
result is used as a mode line element.
If it is a string the string is printed with the following formatting
options:
@table @asis
@item %h
List the number of the head the mode-line belongs to
@item %w
List all windows in the current group windows using @var{*window-format*}
@item %W
List all windows on the current head of the current group using
@var{*window-format*}
@item %g
List the groups using @var{*group-format*}
@end table")
(defvar *screen-mode-line-formatters* '((#\w fmt-window-list)
(#\g fmt-group-list)
(#\h fmt-head)
(#\n fmt-group)
(#\W fmt-head-window-list)
(#\u fmt-urgent-window-list)
(#\v fmt-head-window-list-hidden-windows)
(#\d fmt-modeline-time))
"An alist containing format character format function pairs for
formatting screen mode-lines. functions are passed the screen's
current group.")
(defvar *current-mode-line-formatters* nil
"used in formatting modeline strings.")
(defvar *current-mode-line-formatter-args* nil
"used in formatting modeline strings.")
(defvar *mode-line-timeout* 60
"The modeline updates after each command, when a new window appears or
an existing one disappears, and on a timer. This variable controls how
many seconds elapse between each update. If this variable is changed
while the modeline is visible, you must toggle the modeline to update
timer.")
(defvar *mode-line-timer* nil
"The timer that updates the modeline")
;;; Formatters
(defun add-screen-mode-line-formatter (character fmt-fun)
"Add a format function to a format character (or overwrite an existing one)."
(setf *screen-mode-line-formatters*
(cons (list character fmt-fun)
(remove character *screen-mode-line-formatters* :key #'first))))
;; All mode-line formatters take the mode-line they are being invoked from
;; as the first argument. Additional arguments (everything between the first
;; ',' and the ';' are provided as strings [not yet implemented]).
(defun fmt-urgent-window-list (ml)
"Using *window-format*, return a 1 line list of the urgent windows, space seperated."
(format nil "~{~a~^ ~}"
(mapcar (lambda (w)
(let ((str (format-expand *window-formatters* *window-format* w)))
(if (eq w (current-window))
(fmt-highlight str)
str)))
(screen-urgent-windows (mode-line-screen ml)))))
(defun fmt-window-list (ml)
"Using *window-format*, return a 1 line list of the windows, space seperated."
(format nil "~{~a~^ ~}"
(mapcar (lambda (w) (format-expand *window-formatters* *window-format* w))
(sort-windows (mode-line-current-group ml)))))
(defun fmt-group-list (ml)
"Given a group list all the groups in the group's screen."
(format nil "~{~a~^ ~}"
(mapcar (lambda (w)
(let* ((str (format-expand *group-formatters* *group-format* w)))
(if (eq w (current-group))
(fmt-highlight str)
str)))
(sort-groups (group-screen (mode-line-current-group ml))))))
(defun fmt-head (ml)
(format nil "~d" (head-number (mode-line-head ml))))
(defun fmt-group (ml)
(format nil "~a" (group-name (mode-line-current-group ml))))
(defun fmt-highlight (s)
(format nil "^R~A^r" s))
(defun fmt-head-window-list (ml)
"Using *window-format*, return a 1 line list of the windows, space seperated."
(format nil "~{~a~^ ~}"
(mapcar (lambda (w)
(let ((str (format-expand *window-formatters* *window-format* w)))
(if (eq w (current-window))
(fmt-highlight str)
str)))
(sort1 (head-windows (mode-line-current-group ml) (mode-line-head ml))
#'< :key #'window-number))))
(defun fmt-hidden (s)
(format nil (concat "^[" *hidden-window-color* "~A^]") s))
(defun fmt-head-window-list-hidden-windows (ml)
"Using *window-format*, return a 1 line list of the windows, space
separated. The currently focused window is highlighted with
fmt-highlight. Any non-visible windows are colored the
*hidden-window-color*."
(let* ((all (head-windows (mode-line-current-group ml) (mode-line-head ml)))
(non-top (set-difference all (top-windows))))
(format nil "~{~a~^ ~}"
(mapcar (lambda (w)
(let ((str (format-expand *window-formatters*
*window-format* w)))
(cond ((eq w (current-window)) (fmt-highlight str))
((find w non-top) (fmt-hidden str))
(t str))))
(sort1 all #'< :key #'window-number)))))
(defun fmt-modeline-time (ml)
(declare (ignore ml))
(format-expand *time-format-string-alist* *time-modeline-string*))
(defvar *bar-med-color* "^B")
(defvar *bar-hi-color* "^B^3*")
(defvar *bar-crit-color* "^B^1*")
(defun bar-zone-color (amount &optional (med 20) (hi 50) (crit 90) reverse)
"Return a color command based on the magnitude of the argument. If
the limits for the levels aren't specified, they default to sensible
values for a percentage. With reverse, lower numbers are more
critical."
(labels ((past (n) (funcall (if reverse #'<= #'>=) amount n)))
(cond ((past crit) *bar-crit-color*)
((past hi) *bar-hi-color*)
((past med) *bar-med-color*)
(t ""))))
(defun repeat (n char)
(make-string n :initial-element char))
(defun bar (percent width full empty)
"Return a progress bar string of WIDTH characters composed of characters FULL
and EMPTY at PERCENT complete."
(let ((chars (truncate (* (/ width 100) percent))))
(format nil "^[~A~A^]~A" (bar-zone-color percent)
(repeat chars full)
(repeat (- width chars) empty))))
(defvar *alt-prev-index* 0)
(defvar *alt-prev-time* 0)
;; TODO: Figure out a way to objectify fmt-alternate and fmt-scroll so that
;; multiple instances can coexist.
(defun alternate (strings period)
"Show each of STRINGS, alternating at most once every PERIOD seconds."
(let ((now (/ (get-internal-real-time) internal-time-units-per-second)))
(when (>= (- now *alt-prev-time*) period)
(setf *alt-prev-time* now)
(if (< *alt-prev-index* (1- (length strings)))
(incf *alt-prev-index*)
(setf *alt-prev-index* 0))))
(elt strings *alt-prev-index*))
(defvar *scroll-prev-index* 0)
(defvar *scroll-prev-time* 0)
(defvar *scroll-prev-dir* :forward)
(defun scroll (string width delay)
"Scroll STRING within the space of WIDTH characters, with a step of DELAY"
(let ((now (/ (get-internal-real-time) internal-time-units-per-second)))
(when (>= (- now *scroll-prev-time*) delay)
(setf *scroll-prev-time* now)
(case *scroll-prev-dir*
(:forward
(if (< *scroll-prev-index* (- (length string) width))
(incf *scroll-prev-index*)
(setf *scroll-prev-dir* :backward)))
(:backward
(if (> *scroll-prev-index* 0)
(decf *scroll-prev-index*)
(setf *scroll-prev-dir* :forward))))))
(subseq string *scroll-prev-index* (+ *scroll-prev-index* width)))
(defun make-mode-line-window (parent screen)
"Create a window suitable for a modeline."
(xlib:create-window
:parent parent
:x 0 :y 0 :width 1 :height 1
:background (alloc-color screen *mode-line-background-color*)
:border (alloc-color screen *mode-line-border-color*)
:border-width *mode-line-border-width*
;; You can click the modeline
:event-mask (xlib:make-event-mask :button-press :exposure)
;; these windows are not controlled by the window manager
:override-redirect :on))
(defun resize-mode-line (ml)
(when (eq (mode-line-mode ml) :stump)
;; This is a StumpWM mode-line
(setf (xlib:drawable-height (mode-line-window ml)) (+ (* (1+ (count #\Newline (mode-line-contents ml) :test #'equal)) (font-height (xlib:gcontext-font (mode-line-gc ml)))) (* *mode-line-pad-y* 2))))
(setf (xlib:drawable-width (mode-line-window ml)) (- (frame-width (mode-line-head ml)) (* 2 (xlib:drawable-border-width (mode-line-window ml))))
(xlib:drawable-height (mode-line-window ml)) (min (xlib:drawable-height (mode-line-window ml)) (/ (head-height (mode-line-head ml)) 4))
(mode-line-height ml) (+ (xlib:drawable-height (mode-line-window ml)) (* 2 (xlib:drawable-border-width (mode-line-window ml))))
(mode-line-factor ml) (/ 1 (/ (head-height (mode-line-head ml)) (- (head-height (mode-line-head ml)) (mode-line-height ml))))
(xlib:drawable-x (mode-line-window ml)) (head-x (mode-line-head ml))
(xlib:drawable-y (mode-line-window ml)) (if (eq (mode-line-position ml) :top)
(head-y (mode-line-head ml))
(- (+ (head-y (mode-line-head ml)) (head-height (mode-line-head ml))) (mode-line-height ml)))))
(defgeneric mode-line-format-elt (elt))
(defmethod mode-line-format-elt ((elt string))
(apply 'format-expand *current-mode-line-formatters* elt
*current-mode-line-formatter-args*))
(defmethod mode-line-format-elt ((elt symbol))
(if (boundp elt)
(let ((val (symbol-value elt)))
;; ignore T and nil, like emacs.
(unless (or (eq val t)
(eq val nil))
(mode-line-format-elt val)))
(symbol-name elt)))
(defmethod mode-line-format-elt ((elt null))
"")
(defmethod mode-line-format-elt ((elt list))
(etypecase (first elt)
((or string list)
(apply 'concatenate 'string
(mapcar 'mode-line-format-elt elt)))
(symbol
(mode-line-format-elt
(case (first elt)
;; FIXME: silently failing is probably not the best idea.
(:eval (ignore-errors (eval (second elt))))
(t (and (boundp (first elt))
(symbol-value (first elt))
(second elt))))))))
(defun mode-line-format-string (ml)
(mode-line-format-elt (mode-line-format ml)))
(defun make-mode-line-gc (window screen)
(xlib:create-gcontext :drawable window
:font (screen-font screen)
:foreground (alloc-color screen *mode-line-foreground-color*)
:background (alloc-color screen *mode-line-background-color*)))
(defun update-mode-line-color-context (ml)
(let* ((cc (mode-line-cc ml))
(screen (mode-line-screen ml))
(bright (lookup-color screen *mode-line-foreground-color*)))
(adjust-color bright 0.25)
(setf (ccontext-default-bright cc) (alloc-color screen bright))))
(defun make-head-mode-line (screen head format)
(let* ((w (make-mode-line-window (screen-root screen) screen))
(gc (make-mode-line-gc w screen)))
(make-mode-line :window w
:screen screen
:head head
:format format
:position *mode-line-position*
:cc (make-ccontext :gc gc
:win w
:default-fg (xlib:gcontext-foreground gc)
:default-bg (xlib:gcontext-background gc)))))
(defun mode-line-current-group (ml)
(screen-current-group (mode-line-screen ml)))
(defun redraw-mode-line (ml &optional force)
(when (eq (mode-line-mode ml) :stump)
(let* ((*current-mode-line-formatters* *screen-mode-line-formatters*)
(*current-mode-line-formatter-args* (list ml))
(string (mode-line-format-string ml))
width)
(when (or force (not (string= (mode-line-contents ml) string)))
(setf (mode-line-contents ml) string)
(resize-mode-line ml)
(setf width (render-strings (mode-line-screen ml) (mode-line-cc ml)
*mode-line-pad-x* *mode-line-pad-y*
(split-string string (string #\Newline)) '()))
(rearrange-cubes ml (+ width 10))))))
(defun find-mode-line-window (xwin)
(dolist (s *screen-list*)
(dolist (h (screen-heads s))
(let ((mode-line (head-mode-line h)))
(when (and mode-line (eq (mode-line-window mode-line) xwin))
(return-from find-mode-line-window mode-line))))))
(defun sync-mode-line (ml)
(dolist (group (screen-groups (mode-line-screen ml)))
(group-sync-head group (mode-line-head ml))))
(defun set-mode-line-window (ml xwin)
"Use an external window as mode-line."
(xlib:destroy-window (mode-line-window ml))
(setf (mode-line-window ml) xwin
(mode-line-mode ml) :visible
(xlib:window-priority (mode-line-window ml)) :above)
(resize-mode-line ml)
(sync-mode-line ml))
(defun destroy-mode-line-window (ml)
(xlib:destroy-window (mode-line-window ml))
(setf (head-mode-line (mode-line-head ml)) nil)
(sync-mode-line ml))
(defun move-mode-line-to-head (ml head)
(if (head-mode-line head)
(when (mode-line-head ml)
;; head already has a mode-line. Try swapping them.
(let ((old-head (mode-line-head ml)))
(setf (mode-line-head ml) head
(head-mode-line old-head) (head-mode-line head)
(mode-line-head (head-mode-line head)) old-head
(head-mode-line head) ml)))
(progn
(when (mode-line-head ml)
(setf (head-mode-line (mode-line-head ml)) nil))
(setf (head-mode-line head) ml
(mode-line-head ml) head))))
(defun update-mode-line-position (ml x y)
(let ((head
;; Find the appropriate head
(find-if (lambda (h) (and (= x (head-x h))
(>= y (head-y h))
(< y (+ (head-y h) (head-height h)))))
(screen-heads (mode-line-screen ml)))))
(when (or (not head)
(not (eq (head-mode-line head) ml)))
;; No luck. Just try to find a head without a mode-line already.
(setf head (find-if-not #'head-mode-line (screen-heads (mode-line-screen ml)))))
(if head
(progn
(unless (eq ml (head-mode-line head))
(move-mode-line-to-head ml head))
(when (mode-line-head ml)
(setf (mode-line-position ml) (if (< y (/ (head-height (mode-line-head ml)) 2)) :top :bottom))))
nil)))
(defun place-mode-line-window (screen xwin)
(let ((ml (make-mode-line :window xwin :screen screen :mode :visible :position *mode-line-position*)))
(xlib:reparent-window xwin (screen-root screen) 0 0)
(when (update-mode-line-position ml (xlib:drawable-x xwin) (xlib:drawable-y xwin))
(resize-mode-line ml)
(xlib:map-window xwin)
(sync-mode-line ml))))
(defun update-mode-lines (screen)
"Update all mode lines on SCREEN"
(dolist (h (screen-heads screen))
(let ((mode-line (head-mode-line h)))
(when mode-line
(redraw-mode-line mode-line)))))
(defun update-all-mode-lines ()
"Update all mode lines."
(mapc 'update-mode-lines *screen-list*))
(defun turn-on-mode-line-timer ()
(when (timer-p *mode-line-timer*)
(cancel-timer *mode-line-timer*))
(setf *mode-line-timer* (run-with-timer *mode-line-timeout*
*mode-line-timeout*
'update-all-mode-lines)))
(defun all-heads ()
"Return all heads on all screens."
(loop for s in *screen-list*
nconc (copy-list (screen-heads s))))
(defun maybe-cancel-mode-line-timer ()
(unless (find-if 'head-mode-line (all-heads))
(when (timer-p *mode-line-timer*)
(cancel-timer *mode-line-timer*)
(setf *mode-line-timer* nil))))
(defun toggle-mode-line (screen head &optional (format '*screen-mode-line-format*))
"Toggle the state of the mode line for the specified screen"
(check-type format (or symbol list string))
(let ((ml (head-mode-line head)))
(if ml
(case (mode-line-mode ml)
(:visible
;; Hide it.
(setf (mode-line-mode ml) :hidden)
(xlib:unmap-window (mode-line-window ml)))
(:hidden
;; Show it.
(setf (mode-line-mode ml) :visible)
(xlib:map-window (mode-line-window ml)))
(:stump
;; Delete it
(xlib:destroy-window (mode-line-window ml))
(xlib:free-gcontext (mode-line-gc ml))
(setf (head-mode-line head) nil)
(maybe-cancel-mode-line-timer)))
(progn
(setf (head-mode-line head) (make-head-mode-line screen head format))
(update-mode-line-color-context (head-mode-line head))
(resize-mode-line (head-mode-line head))
(xlib:map-window (mode-line-window (head-mode-line head)))
(add-cube-switch-hook)
(create-mode-line-cubes (head-mode-line head))
(redraw-mode-line (head-mode-line head))
(dformat 3 "modeline: ~s~%" (head-mode-line head))
;; setup the timer
(turn-on-mode-line-timer)))
(dolist (group (screen-groups screen))
(group-sync-head group head))))
(defun enable-mode-line (screen head state &optional format)
"Set the state of SCREEN's HEAD's mode-line. If STATE is T and FORMAT is
specified, then the mode-line's format is updated."
(check-type screen screen)
(check-type head head)
(check-type format (or symbol list string))
(if state
(if (head-mode-line head)
(when format
(setf (mode-line-format (head-mode-line head)) format))
(toggle-mode-line screen head (or format *screen-mode-line-format*)))
(when (head-mode-line head)
(toggle-mode-line screen head))))
(defcommand mode-line () ()
"A command to toggle the mode line visibility."
(toggle-mode-line (current-screen) (current-head)))
Jump to Line
Something went wrong with that request. Please try again.