├── .gitignore ├── README.org ├── applications.lisp ├── binds.lisp ├── border.lisp ├── clean.lisp ├── config ├── debug.lisp ├── defaults.lisp ├── emacs.lisp ├── groups.lisp ├── menu.lisp ├── mode-line.lisp ├── mouse.lisp ├── preload.lisp ├── scratchpad.lisp ├── session.lisp └── window.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | /local.lisp 2 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: My StumpWM Config 2 | 3 | * Summary 4 | This is my StumpWM personal config. Do what you want with it. Summary of its contents follows. 5 | * Files 6 | ** preload/local 7 | *** after-load-conf 8 | This allows me to write system specific hooks to customize StumpWM inside of =local.lisp=. 9 | 10 | #+BEGIN_SRC lisp 11 | (in-package :hfj) 12 | 13 | (after-load-conf ("clean.lisp") 14 | (message "clean.lisp has been processed!")) 15 | #+END_SRC 16 | ** clean 17 | Removes the various hooks I use so I don't have left-over hooks that are called after I've done a "loadrc". 18 | ** defaults 19 | Add an =after-load-conf= hook to override these. 20 | *** *group-names* 21 | List of group names to be created. 22 | *** *frame-preferences* 23 | List of preferences to pass to define-frame-preference. 24 | ** debug 25 | *** my-debug 26 | Simple logging to a specific file. 27 | 28 | #+BEGIN_SRC lisp 29 | (my-debug "Window:" window "Frame:" frame) 30 | #+END_SRC 31 | ** menu 32 | Menu on =super-o=. Has wrappers for ~defcommand~ to add commands to the menu when they are defined. 33 | 34 | For example, I can add a "Browser" under "Apps" in the default menu. 35 | #+BEGIN_SRC lisp 36 | (defapp run-firefox () () ("Browser") 37 | "Run Firefox" 38 | (run-or-raise "firefox-bin" '(:class "Firefox"))) 39 | #+END_SRC 40 | 41 | I can add a program that disables the touchpad under "Utility" in the default menu. 42 | #+BEGIN_SRC lisp 43 | (defutil toggle-touchpad () () ("Toggle touchpad") 44 | "Enable/Disable touchpad" 45 | (run-shell-command "toggle-touchpad")) 46 | #+END_SRC 47 | 48 | Or to any menu I've defined with any level of sub-menus. 49 | #+BEGIN_SRC lisp 50 | (def-menu-command pick-me-command () () (*default-menu* "Top" "Middle" "Pick Me!") 51 | "Example!" 52 | (message "Picked!")) 53 | #+END_SRC 54 | 55 | Even comes with a StumpWM menu for reloading, restarting, and starting/stopping swank. 56 | ** emacs 57 | Commands to start and stop swank. 58 | ** window 59 | *** with-new-window 60 | Macro to start a process and capture its window and modify it. 61 | 62 | Sample from scratchpad.lisp: 63 | #+BEGIN_SRC lisp 64 | (hfj:with-new-window (window cmd) 65 | :new 66 | (push (cons name window) *scratch-floats*) 67 | :focus 68 | (stumpwm::float-window window (current-group)) 69 | (cond (initial-gravity 70 | (resize-by-gravity window initial-gravity ratio)))) 71 | #+END_SRC 72 | 73 | Example to float an xterm: 74 | #+BEGIN_SRC lisp 75 | (with-new-window (window "xterm") 76 | (stumpwm::float-window window (current-group)) 77 | (stumpwm::float-window-move-resize window 78 | :x 50 :y 70 79 | :width 540 :height 400)) 80 | #+END_SRC 81 | ** scratchpad 82 | Create a "scratchpad" that can be toggled with a single keypress. Two variants exist, to present the window tiled or floating. I haven't finished tweaking these yet, so don't expect them to work perfectly yet. 83 | *** toggle-split-scratchpad 84 | Show a window in a frame above, below, left or right of the current frame. Splits with =*default-split-ratio*= by default. Uses gravity to determine the split. Corner gravity will pick the shorter of the two sides to place the split. 85 | 86 | Example: 87 | #+BEGIN_SRC lisp 88 | (defcommand scratchpad-test () () 89 | (scratchpad::toggle-split-scratchpad "my-xterm" "xterm" 90 | :gravity :top-right 91 | :ratio 1/3)) 92 | #+END_SRC 93 | *** toggle-floating-scratchpad 94 | Floats a window on the current screen based on gravity. Splits with =*default-float-ratio*= by default. Also has a command ~scratchpad-float~. 95 | 96 | Examples: 97 | #+BEGIN_SRC lisp 98 | (defcommand scratchpad-test () () 99 | (scratchpad::toggle-split-scratchpad "my-xterm" "xterm" 100 | :gravity :center 101 | :ratio 1/3)) 102 | #+END_SRC 103 | 104 | #+BEGIN_SRC lisp 105 | (define-key *top-map* (kbd "s-TAB") "scratchpad-float yakyak-scratch yakyak left") 106 | #+END_SRC 107 | ** applications 108 | Various applications. Uses ~defapp~ and ~defutil~ to place commands directly into the menu. 109 | 110 | Also has functions to start named instances of tmux and emacs. This way I can type =s-a e e= and get an instance of emacs named "e" and I can raise it quickly with the same keypresses. Or =s-a e r= for one named "r". Makes it easy to switch back to or between instances of emacs. 111 | ** groups 112 | Set up groups and preferences defined in defaults.lisp. 113 | ** session 114 | A menu on =s-q= for logging out and shutting down. I should probably move this over to the main menu. 115 | ** binds 116 | Bindings. Uses some convenience functions to simplify maintenance. 117 | 118 | #+BEGIN_SRC lisp 119 | (alist-define-keys *top-map* 120 | '(("s-h" . "move-focus left") 121 | ("s-j" . "move-focus down") 122 | ("s-k" . "move-focus up") 123 | ("s-l" . "move-focus right"))) 124 | 125 | ;; Create and initialize a set of bindings off "s-f". 126 | (alist-define-keys (create-map *frame-map* "s-f") 127 | '(("f" . "frame-windowlist") 128 | ("s-f" . "fother") 129 | ("n" . "next-in-frame") 130 | ("p" . "prev-in-frame") 131 | ("e" . "fclear") 132 | ("m" . "only") 133 | ("=" . "balance-frames"))) 134 | 135 | ;; Or one off "s-w m" 136 | (alist-define-keys (create-map *window-move-map* "m" :on *window-map*) 137 | '(("h" . "move-window left") ;; That is, "s-w m h" 138 | ("j" . "move-window down") 139 | ("k" . "move-window up") 140 | ("l" . "move-window right"))) 141 | #+END_SRC 142 | ** mouse 143 | Set focus to follow the mouse, and the mouse to follow focus. 144 | ** border 145 | For styles which I haven't really gotten around to messing with yet. 146 | ** mode-line 147 | Basic mode line config. 148 | -------------------------------------------------------------------------------- /applications.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | (ql:quickload "str") 3 | 4 | (defun string-escape (str) 5 | "Escape a string" 6 | (format nil "~S" str)) 7 | 8 | (defun named-terminal-title (name) 9 | "Title for named terminal" 10 | (format nil "tmux - ~A" name)) 11 | 12 | (defun probe-file-env-paths (name) 13 | "Probe file across paths in $PATH. Returns first pathname found or nil." 14 | (loop for path in (str:split ":" (uiop:getenv "PATH") :omit-nulls t) 15 | thereis (probe-file (merge-pathnames name (make-pathname :directory path))))) 16 | 17 | (defcommand xbacklight (args) ((:shell "Arguments: ")) 18 | "Run xbacklight" 19 | (run-shell-command (format nil "xbacklight ~S" args))) 20 | 21 | (defcommand amixer (args) ((:shell "Arguments: ")) 22 | "Run amixer" 23 | (run-shell-command (format nil "amixer ~A" args))) 24 | 25 | (defcommand lock () () 26 | "Lock session" 27 | (run-shell-command "dm-tool lock")) 28 | 29 | (defapp run-firefox () () ("Browser") 30 | "Run Firefox" 31 | (run-or-raise "firefox-bin" '(:class "Firefox"))) 32 | 33 | (defapp run-named-terminal (name) ((:string "Name: ")) ("Terminal") 34 | "Run terminal" 35 | (let* ((title (named-terminal-title name)) 36 | (args (list 37 | "st" 38 | "-t" title ;; Title 39 | "-f" "Source Code Pro" 40 | "-e" "/usr/bin/tmux" "new-session" "-AD" "-s" name)) 41 | (cmd (str:join " " (map 'list #'string-escape args)))) 42 | (run-or-raise cmd `(:title ,title)))) 43 | 44 | (defapp run-chrome () () ("Browser (Chrome)") 45 | "Run Chrome" 46 | (run-or-raise "firejail google-chrome-stable" '(:class "Google-chrome"))) 47 | 48 | (defapp run-thunderbird () () ("Email") 49 | "Run Thunderbird" 50 | (let ((path (loop for file in '("thunderbird-bin" "thunderbird") 51 | thereis (probe-file-env-paths file)))) 52 | (when path 53 | (run-or-raise (namestring path) '(:class "Thunderbird"))))) 54 | 55 | (defapp run-keepassxc () () ("Passwords") 56 | "Run KeepassXC" 57 | (run-or-raise "keepassxc" '(:class "keepassxc"))) 58 | 59 | (defutil toggle-touchpad () () ("Toggle touchpad") 60 | "Enable/Disable touchpad" 61 | (run-shell-command "toggle-touchpad")) 62 | 63 | (flet ((emacs-daemon-running-p () 64 | "Determine if emacs daemon running." 65 | (when-let ((output (run-shell-command "emacsclient --eval t" t))) 66 | (string= "t" (str:trim output)))) 67 | (emacs-name-plist (name) 68 | (let* ((title (format nil "Emacs - ~A" name)) 69 | (name-str (format nil "(name . ~S)" title)) 70 | (title-str (format nil "(title . ~S)" title)) 71 | (form (format nil "(~A ~A)" name-str title-str)) 72 | (args (list "/usr/bin/emacsclient" "-c" "-F" (string-escape form))) 73 | (client-cmd (str:join " " args)) 74 | (non-client-cmd (format nil "/usr/bin/emacs --title ~S --name ~S" title title))) 75 | (list :title title 76 | :client-cmd client-cmd 77 | :non-client-cmd non-client-cmd)))) 78 | (defapp display-named-emacs (name &optional force-serverless) 79 | ((:string "Name: ") (:y-or-n "Force server-less: ")) 80 | ("Emacs") 81 | "Raise emacs frame with given name" 82 | (let ((plist (emacs-name-plist name))) 83 | (if (and (not force-serverless) 84 | (emacs-daemon-running-p)) 85 | (run-or-raise (getf plist :client-cmd) `(:title ,(getf plist :title))) 86 | (run-or-raise (getf plist :non-client-cmd) `(:title ,(getf plist :title))))))) 87 | 88 | (defapp run-yakyak () () ("IM") 89 | "Run Yakyak" 90 | (run-or-raise "yakyak" '(:class "yakyak"))) 91 | -------------------------------------------------------------------------------- /binds.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | 3 | (defun alist-define-keys (map alist) 4 | "define key using alist." 5 | (loop for (key . command) in alist 6 | do (define-key map (kbd key) command))) 7 | 8 | (defmacro create-map (var key &key (on *top-map*)) 9 | `(progn 10 | (defparameter ,var (make-sparse-keymap)) 11 | (define-key ,on (kbd ,key) ',var) 12 | ,var)) 13 | 14 | (alist-define-keys *top-map* 15 | '(("s-h" . "move-focus left") 16 | ("s-j" . "move-focus down") 17 | ("s-k" . "move-focus up") 18 | ("s-l" . "move-focus right") 19 | 20 | ("s-H" . "move-window left") 21 | ("s-J" . "move-window down") 22 | ("s-K" . "move-window up") 23 | ("s-L" . "move-window right") 24 | 25 | ("s-M-H" . "exchange-direction left") 26 | ("s-M-J" . "exchange-direction down") 27 | ("s-M-K" . "exchange-direction up") 28 | ("s-M-L" . "exchange-direction right") 29 | 30 | ("s-;" . "colon") 31 | 32 | ("s-b" . "fullscreen") 33 | 34 | ("s-TAB" . "grouplist") 35 | 36 | ("s-m" . "banish window") 37 | 38 | ("s-n" . "next-in-frame") 39 | ("s-p" . "prev-in-frame") 40 | 41 | ("s-q" . "session-menu") 42 | 43 | ("s-o" . "show-menu") 44 | 45 | ("s-x" . "run-shell-command") 46 | 47 | ("s-z" . "mark") 48 | ("s-Z" . "gmove-marked") 49 | 50 | ("s-`" . "scratchpad-float yakyak yakyak left") 51 | 52 | ("XF86ScreenSaver" . "lock") 53 | 54 | ("S-XF86MonBrightnessUp" . "xbacklight =100%") 55 | ("S-XF86MonBrightnessDown" . "xbacklight =3%") 56 | ("XF86MonBrightnessUp" . "xbacklight +5%") 57 | ("XF86MonBrightnessDown" . "xbacklight -5%") 58 | 59 | ("XF86AudioRaiseVolume" . "amixer -c 0 sset Master 1+") 60 | ("XF86AudioLowerVolume" . "amixer -c 0 sset Master 1-") 61 | 62 | ("XF86AudioMute" . "amixer sset Master,0 toggle") 63 | 64 | ("S-XF86AudioRaiseVolume" . "amixer -c 0 sset Capture 1+") 65 | ("S-XF86AudioLowerVolume" . "amixer -c 0 sset Capture 1-") 66 | 67 | ("XF86AudioMicMute" . "amixer sset Capture,0 toggle"))) 68 | (loop for i from 1 to 9 69 | do (let ((key (kbd (format nil "s-~A" i))) 70 | (action (format nil "fselect ~A" (1- i)))) 71 | (define-key *top-map* key action))) 72 | 73 | (loop for ch in '(#\) #\! #\@ #\# #\$ #\% #\^ #\& #\* #\() 74 | and i from 0 to 9 75 | do (let ((key (kbd (format nil "s-~A" ch))) 76 | (action (format nil "gmove ~A" i))) 77 | (define-key *top-map* key action))) 78 | 79 | (alist-define-keys (create-map *frame-map* "s-f") 80 | '(("f" . "frame-windowlist") 81 | ("s-f" . "fother") 82 | ("n" . "next-in-frame") 83 | ("p" . "prev-in-frame") 84 | ("e" . "fclear") 85 | ("m" . "only") 86 | ("=" . "balance-frames"))) 87 | (loop for i from 0 to 9 88 | do (let ((key (kbd (format nil "~A" i))) 89 | (action (format nil "fselect ~A" i))) 90 | (define-key *frame-map* key action))) 91 | 92 | (alist-define-keys (create-map *window-map* "s-w") 93 | '(("h" . "move-focus left") 94 | ("j" . "move-focus down") 95 | ("k" . "move-focus up") 96 | ("l" . "move-focus right") 97 | 98 | ("q" . "delete") 99 | ("Q" . "kill") 100 | 101 | ("n" . "pull-hidden-next") 102 | ("p" . "pull-hidden-previous") 103 | 104 | ("w" . "windowlist-all") 105 | ("s-w" . "switch-to-previous-window") 106 | 107 | ("g" . "gmove") 108 | ("m" . "only") 109 | 110 | ("t" . "mark") 111 | 112 | ("s" . "vsplit") 113 | ("v" . "hsplit") 114 | ("d" . "remove") 115 | ("r" . "iresize-hfj"))) 116 | (loop for i from 0 to 9 117 | do (let ((key (kbd (write-to-string i))) 118 | (action (format nil "select-window-by-number ~A" i))) 119 | (define-key *window-map* key action))) 120 | 121 | (alist-define-keys (create-map *window-move-map* "m" :on *window-map*) 122 | '(("h" . "move-window left") 123 | ("j" . "move-window down") 124 | ("k" . "move-window up") 125 | ("l" . "move-window right"))) 126 | 127 | (alist-define-keys (create-map *window-transpose-map* "x" :on *window-map*) 128 | '(("h" . "exchange-direction left") 129 | ("j" . "exchange-direction down") 130 | ("k" . "exchange-direction up") 131 | ("l" . "exchange-direction right"))) 132 | 133 | (alist-define-keys (create-map *group-map* "s-g") 134 | '(("g" . "grouplist") 135 | ("s-g" . "gother") 136 | 137 | ("n" . "gnext") 138 | ("N" . "gnext-with-window") 139 | 140 | ("p" . "gprev") 141 | ("P" . "gprev-with-window") 142 | 143 | ("t" . "gmove-marked") 144 | 145 | ("c" . "gnew") 146 | ("q" . "gkill") 147 | ("r" . "grename"))) 148 | (loop for i from 0 to 9 149 | do (let ((key (kbd (format nil "~A" i))) 150 | (action (format nil "gselect ~A" i))) 151 | (define-key *group-map* key action))) 152 | 153 | (alist-define-keys (create-map *systray-map* "s-s") 154 | '(("j" . "stumptray-toggle-hidden-icons-visibility") 155 | ("k" . "systray-toggle-icon-hiding") 156 | 157 | ("h" . "systray-selection-left") 158 | ("l" . "systray-selection-right") 159 | 160 | ("H" . "systray-move-icon-left") 161 | ("L" . "systray-move-icon-right") 162 | 163 | ("s" . "stumptray"))) 164 | 165 | (alist-define-keys (create-map *applications-map* "s-a") 166 | '(("f" . "run-firefox") 167 | ("c" . "run-chrome") 168 | ("k" . "run-keepassxc") 169 | ("t" . "run-named-terminal main") 170 | ("m" . "run-thunderbird") 171 | ("y" . "run-yakyak"))) 172 | 173 | (alist-define-keys (create-map *applications-emacs* "e" :on *applications-map*) 174 | '(("e" . "display-named-emacs main n") 175 | ("E" . "display-named-emacs main y"))) 176 | 177 | (loop for c across "abcdfghijklmnopqrstuvwxyz0123456789" 178 | do (let ((key (kbd (string c))) 179 | (action (format nil "display-named-emacs ~C n" c))) 180 | (define-key *applications-emacs* key action))) 181 | (loop for c across "ABCDFGHIJKLMNOPQRSTUVWXYZ" 182 | do (let ((key (kbd (string c))) 183 | (action (format nil "display-named-emacs ~C y" (char-downcase c)))) 184 | (define-key *applications-emacs* key action))) 185 | 186 | (define-key stumpwm:*menu-map* (kbd "TAB") 'menu-down) 187 | (define-key stumpwm:*menu-map* (kbd "M-TAB") 'menu-down) 188 | (define-key stumpwm:*menu-map* (kbd "s-TAB") 'menu-up) 189 | -------------------------------------------------------------------------------- /border.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | 3 | (setf *window-border-style* :thin) 4 | (setf *normal-border-width* 1) 5 | -------------------------------------------------------------------------------- /clean.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | 3 | (clear-window-placement-rules) 4 | 5 | ;; Clear hooks I use on restart 6 | (remove-all-hooks *new-window-hook*) 7 | (remove-all-hooks *focus-group-hook*) 8 | (remove-all-hooks *focus-window-hook*) 9 | (remove-all-hooks *focus-frame-hook*) 10 | (remove-all-hooks *split-frame-hook*) 11 | (remove-all-hooks *remove-split-hook*) 12 | -------------------------------------------------------------------------------- /config: -------------------------------------------------------------------------------- 1 | ;; -*-lisp-*- 2 | (ql:quickload "anaphora") 3 | (in-package :cl-user) 4 | (defpackage hfj 5 | (:use :cl :stumpwm :alexandria :anaphora)) 6 | (in-package :hfj) 7 | 8 | (set-module-dir (uiop:subpathname* (user-homedir-pathname) "opt/stumpwm/contrib/")) 9 | (setf *config-path* (uiop:subpathname* (user-homedir-pathname) ".config/stumpwm/")) 10 | (load (uiop:subpathname* *config-path* "preload.lisp")) 11 | 12 | ;; Place local hooks in local.lisp. Use after-load-conf to attach to sections. 13 | (awhen (probe-file (uiop:subpathname* *config-path* "local.lisp")) 14 | (load it)) 15 | (load-conf "clean.lisp") 16 | (load-conf "defaults.lisp") 17 | (load-conf "debug.lisp") 18 | (load-conf "menu.lisp") 19 | (load-conf "emacs.lisp") 20 | (load-conf "window.lisp") 21 | (load-conf "scratchpad.lisp") 22 | (load-conf "applications.lisp") 23 | (load-conf "groups.lisp") 24 | (load-conf "session.lisp") 25 | (load-conf "binds.lisp") 26 | (load-conf "mouse.lisp") 27 | (load-conf "border.lisp") 28 | (load-conf "mode-line.lisp") 29 | -------------------------------------------------------------------------------- /debug.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | (export 'my-debug) 3 | 4 | (defun my-debug (&rest data) 5 | (with-open-file (stream (uiop:subpathname* (user-homedir-pathname) "tmp/stumpwm.txt") 6 | :direction :output 7 | :if-exists :append 8 | :if-does-not-exist :create) 9 | (format stream "~&~A" (first data)) 10 | (loop for item in (rest data) 11 | do (format stream " ~A" item)) 12 | (terpri stream))) 13 | -------------------------------------------------------------------------------- /defaults.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | 3 | (defvar *group-names* '("Emacs" 4 | "Browser" 5 | "Terminal" 6 | "Email") 7 | "List of group names to be created.") 8 | 9 | (defvar *frame-preferences* '(("Emacs" 10 | (0 t t :title "Emacs - main")) 11 | ("Browser" 12 | (0 t t :class "Firefox") 13 | (1 t t :class "Google-chrome") 14 | (2 t t :class "keepassxc")) 15 | ("Email" 16 | (0 t t :class "Thunderbird")) 17 | ("Terminal" 18 | (0 t t :title "tmux - main"))) 19 | "List of preferences to pass to define-frame-preference.") 20 | -------------------------------------------------------------------------------- /emacs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | 3 | (ql:quickload "swank") 4 | (swank-loader:init) 5 | 6 | (defvar *swank-port* nil) 7 | 8 | (def-menu-command start-swank (port) ((:number "Port: ")) (*default-stumpwm-menu* "Start Swank") 9 | (when port 10 | (when *swank-port* 11 | (ignore-errors (swank:stop-server *swank-port*))) 12 | (setf *swank-port* port) 13 | (swank:create-server :port port 14 | :style swank:*communication-style* 15 | :dont-close nil))) 16 | 17 | (def-menu-command stop-swank () () (*default-stumpwm-menu* "Stop Swank") 18 | (when *swank-port* 19 | (ignore-errors (swank:stop-server *swank-port*)))) 20 | -------------------------------------------------------------------------------- /groups.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | 3 | (when (consp *group-names*) 4 | (grename (first *group-names*)) 5 | (loop for name in (rest *group-names*) 6 | do (add-group (current-screen) name))) 7 | 8 | (when (consp *frame-preferences*) 9 | (loop for (name . prefs) in *frame-preferences* 10 | do (eval `(define-frame-preference ,name ,@prefs)))) 11 | -------------------------------------------------------------------------------- /menu.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | (ql:quickload "str") 3 | (export '(add-menu-item 4 | def-menu-command 5 | defapp 6 | defutil)) 7 | 8 | (defparameter *default-menu-name* "Menu") 9 | 10 | (defparameter *default-menu* 11 | '(("Apps" (:submenu *default-apps-menu*)) 12 | ("Utility" (:submenu *default-util-menu*)) 13 | ("StumpWM" (:submenu *default-stumpwm-menu*)))) 14 | 15 | (defparameter *default-apps-menu* nil) 16 | 17 | (defparameter *default-util-menu* nil) 18 | 19 | (defparameter *default-stumpwm-menu* 20 | '(("Restart hard" restart-hard) 21 | ("Restart soft" restart-soft) 22 | ("Reload RC" loadrc))) 23 | 24 | (defun data-is-submenu-p (data) 25 | (listp data)) 26 | 27 | (defun menu-item-name (row) 28 | (first row)) 29 | 30 | (defun menu-item-data (row) 31 | (second row)) 32 | 33 | (defun walk-menu (menu on-descend on-leaf on-ascend) 34 | "Walk a menu. 35 | on-descend takes sub-menu. 36 | on-leaf takes leaf. 37 | on-ascend takes list of results of on-leaf and on-ascend from children." 38 | (loop for row in menu 39 | for data = (descend-data (menu-item-data row)) 40 | collect (cond ((data-is-submenu-p data) 41 | (funcall on-descend data) 42 | (funcall on-ascend (walk-menu data on-descend on-leaf on-ascend))) 43 | (t 44 | (funcall on-leaf data))))) 45 | 46 | (defun menu-item-count (menu) 47 | "Determine how many items are in a menu. Includes sub-menus." 48 | (reduce #'+ (walk-menu menu 49 | #'(lambda (submenu) 50 | (declare (ignore submenu))) 51 | #'(lambda (leaf) 52 | (if leaf 1 0)) 53 | #'(lambda (results) (reduce #'+ results))))) 54 | 55 | (defun remove-empty-submenus (menu) 56 | "Skip any sub-menus that are empty." 57 | (loop for row in menu 58 | for data = (descend-data (menu-item-data row)) 59 | when (or (not (data-is-submenu-p data)) 60 | (< 0 (menu-item-count data))) 61 | collect row)) 62 | 63 | (defun append-menu-names (title menu) 64 | "Convert menu of two items per row two three, where first is a pretty title." 65 | (let* ((longest-size (reduce #'(lambda (val row) 66 | (max val (length (menu-item-name row)))) 67 | menu 68 | :initial-value 0)) 69 | (has-submenu (loop for row in menu 70 | thereis (data-is-submenu-p (menu-item-data row)))) 71 | ;; When apps have " ->" postfix, commands need " " 72 | (submenu-postfix " ->") 73 | (command-postfix (if has-submenu 74 | (make-string (length submenu-postfix) 75 | :initial-element #\Space) 76 | "")) 77 | (longest-with-postfix (+ (length command-postfix) 78 | longest-size)) 79 | (title-size (length title)) 80 | (prefix (if (< longest-with-postfix title-size) 81 | (make-string (- title-size longest-with-postfix) 82 | :initial-element #\Space) 83 | ""))) 84 | (labels ((cons-nice-name (row) 85 | (let ((title (menu-item-name row)) 86 | (content (menu-item-data row))) 87 | (cond 88 | ;; Submenu 89 | ((data-is-submenu-p content) 90 | (cons (concat prefix 91 | (make-string (- longest-size (length title)) 92 | :initial-element #\Space) 93 | title 94 | submenu-postfix) 95 | row)) 96 | ;; Command 97 | (t (cons (concat prefix 98 | (make-string (- longest-size (length title)) 99 | :initial-element #\Space) 100 | title 101 | command-postfix) 102 | row)))))) 103 | (map 'list #'cons-nice-name menu)))) 104 | 105 | (defun run-submenu (menu &optional path previous-menus selected-entry) 106 | "Present menu to user." 107 | (let ((selection 108 | (let* ((title (str:join "/" (reverse path))) 109 | (smenu (sort (append-menu-names title (remove-empty-submenus menu)) 110 | #'(lambda (a b) 111 | (string-lessp (second a) 112 | (second b))))) 113 | (pos (or (and selected-entry 114 | (position-if #'(lambda (row) 115 | (string-equal selected-entry 116 | (second row))) 117 | smenu)) 118 | 0))) 119 | (select-from-menu (current-screen) 120 | smenu 121 | title 122 | pos)))) 123 | (cond 124 | ;; Ascend to previous 125 | ((and (null selection) 126 | previous-menus) 127 | (run-submenu (first previous-menus) 128 | (rest path) 129 | (rest previous-menus) 130 | (first path))) 131 | ;; End 132 | ((null selection) 133 | nil) 134 | (t (let ((name (second selection)) 135 | (data (descend-data (third selection)))) 136 | (cond 137 | ;; Submenu 138 | ((data-is-submenu-p data) 139 | (run-submenu data 140 | (cons name path) 141 | (cons menu previous-menus))) 142 | ;; CLI command to run 143 | ((stringp data) 144 | (run-shell-command data)) 145 | ;; Lisp function to run 146 | ((symbolp data) 147 | (run-commands (string data))) 148 | ;; Unknown 149 | (t 150 | (error "Unknown menu data: ~S" selection)))))))) 151 | 152 | (defcommand show-menu (&optional (menu *default-menu*) (name *default-menu-name*)) () 153 | (run-submenu menu (list name))) 154 | 155 | (defun descend-data (data) 156 | (cond ((and (consp data) 157 | (eq :submenu (first data))) 158 | (symbol-value (second data))) 159 | (t 160 | data))) 161 | 162 | (defun find-menu-row (name menu &key (offset 0)) 163 | "Find menu item from name and return submenu or item or nil." 164 | (find-if #'(lambda (row) 165 | (string-equal (elt row offset) name)) 166 | menu)) 167 | 168 | (defun descend-menu (name menu &key (offset 0)) 169 | "Find menu item from name and return submenu or item or nil." 170 | (let ((row (find-menu-row name menu offset))) 171 | (when row 172 | (descend-data (elt row (+ 1 offset)))))) 173 | 174 | (defun append-menu-f (menu name data) 175 | "Find menu item from name and return submenu or item or nil." 176 | (push (list name data) menu) 177 | menu) 178 | 179 | (defmacro replace-menu-f (menu name data) 180 | "Find menu item from name and return submenu or item or nil." 181 | `(progn 182 | (check-type ,menu cons) 183 | (check-type ,name string) 184 | (setf ,menu (delete-if #'(lambda (row) 185 | (string-equal ,name 186 | (menu-item-name row))) 187 | ,menu)) 188 | (append-menu-f ,menu ,name ,data))) 189 | 190 | (defun new-menus (path data) 191 | (list (if (= 1 (length path)) 192 | (list (first path) data) 193 | (list (first path) (list (new-menus (rest path) data)))))) 194 | 195 | (defmacro add-menu-item (menu path f) 196 | `(cond ((null ,menu) 197 | (setf ,menu (new-menus ,path ,f))) 198 | (t 199 | (setf ,menu (add-menu-item-helper ,menu ,path ,f))))) 200 | 201 | (defun add-menu-item-helper (menu path f) 202 | (check-type menu cons) 203 | (labels ((add (title) 204 | (replace-menu-f menu title f))) 205 | (cond 206 | ;; Insert here if string 207 | ((stringp path) 208 | (add path)) 209 | ;; Insert here if last path 210 | ((= 1 (length path)) 211 | (add (first path))) 212 | (t (let ((name (first path)) 213 | (remaining (rest path))) 214 | (acond 215 | ;; Descend: Path exists already 216 | ((find-menu-row name menu) 217 | (let* ((row it) 218 | (raw-data (menu-item-data row)) 219 | (data (descend-data raw-data))) 220 | (cond 221 | ((and (consp raw-data) 222 | (eq :submenu (first raw-data))) 223 | ;; Don't change menu, change submenu referenced by symbol 224 | (let ((sym-name (second raw-data))) 225 | (add-menu-item (symbol-value sym-name) remaining f) 226 | menu)) 227 | ((data-is-submenu-p data) 228 | (replace-menu-f menu name 229 | (add-menu-item data remaining f))) 230 | (t (replace-menu-f menu name (new-menus remaining f)))))) 231 | ;; Descend: Path is new 232 | (t (replace-menu-f menu name (new-menus remaining f))))))))) 233 | 234 | (defmacro def-menu-command (name (&rest args) (&rest args-meta) (menu &rest menu-path) &body body) 235 | "Create command and add to menu at the same time." 236 | `(progn 237 | (defcommand ,name (,@args) (,@args-meta) 238 | ,@body) 239 | (add-menu-item ,menu (list ,@menu-path) ',name))) 240 | 241 | (defmacro defapp (name (&rest args) (&rest args-meta) (&rest menu-path) &body body) 242 | "Create command and add to Apps menu at the same time." 243 | `(def-menu-command ,name (,@args) (,@args-meta) (*default-apps-menu* ,@menu-path) 244 | ,@body)) 245 | 246 | (defmacro defutil (name (&rest args) (&rest args-meta) (&rest menu-path) &body body) 247 | "Create command and add to Utility menu at the same time." 248 | `(def-menu-command ,name (,@args) (,@args-meta) (*default-util-menu* ,@menu-path) 249 | ,@body)) 250 | 251 | -------------------------------------------------------------------------------- /mode-line.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage hfj.mode-line 3 | (:use :cl :hfj :stumpwm)) 4 | (in-package :hfj.mode-line) 5 | 6 | (ql:quickload "clx-truetype") 7 | 8 | (setf *mode-line-position* :bottom) 9 | 10 | ;; (load-module "app-menu") 11 | (load-module "battery-portable") 12 | (load-module "cpu") 13 | (load-module "mem") 14 | (load-module "net") 15 | (load-module "wifi") 16 | (load-module "stumptray") 17 | (load-module "ttf-fonts") 18 | 19 | (xft:cache-fonts) 20 | (set-font (make-instance 'xft:font :family "Iosevka Light" :subfamily "Regular" :size 10)) 21 | 22 | 23 | (defun only-float-windows (windows) 24 | "Mirror of only-tile-windows." 25 | (remove-if-not (lambda (w) 26 | (typep w 'stumpwm::float-window)) 27 | windows)) 28 | 29 | (defun group-float-windows (group) 30 | "Mirror of group-tile-windows." 31 | (only-float-windows (stumpwm::group-windows group))) 32 | 33 | (defun mode-line-hidden-windows (ml) 34 | (let* ((group (stumpwm::mode-line-current-group ml)) 35 | (current-frame (stumpwm::tile-group-current-frame group)) 36 | (all (concatenate 'list 37 | (group-float-windows group) 38 | (stumpwm::frame-windows group current-frame)))) 39 | (format nil "~{~a~^ | ~}" 40 | (mapcar (lambda (w) 41 | (let ((str (stumpwm::format-expand *window-formatters* 42 | *window-format* 43 | w))) 44 | (cond ((eq w (stumpwm::current-window)) 45 | (stumpwm::fmt-highlight str)) 46 | (t str)))) 47 | (stumpwm::sort1 all #'< :key #'window-number))))) 48 | 49 | (add-screen-mode-line-formatter #\V #'mode-line-hidden-windows) 50 | 51 | (setf *window-format* "%m%s%n.%8c - %20t") 52 | 53 | (setf *group-format* "%s%t") 54 | 55 | (defun has-battery-p () 56 | (or (probe-file "/sys/class/power_supply/BAT0") 57 | (probe-file "/sys/class/power_supply/BAT1"))) 58 | 59 | (defun has-wireless-p () 60 | (loop 61 | for path in (directory #P"/sys/class/net/*") 62 | thereis (probe-file (merge-pathnames (make-pathname :directory '(:relative "wireless")) 63 | path)))) 64 | 65 | (let ((battery (and (has-battery-p) "BAT: %B")) 66 | (groups "%g") 67 | (current-group "%n") 68 | (sep " | ") 69 | (align-right "^>") 70 | (hidden-windows "%V") 71 | (cpu "%c") 72 | (cpu-bar "%C") 73 | (cpu-temp "%t") 74 | (cpu-freq "%f") 75 | (mem "%M") 76 | (wifi (and (has-wireless-p) "%I")) 77 | (date "%d") 78 | (_ " ") 79 | (right-padding (make-string 7 :initial-element #\Space))) 80 | (let ((left (list current-group sep hidden-windows)) 81 | (right (list battery (and battery _) cpu mem wifi _ date right-padding))) 82 | (setf *screen-mode-line-format* 83 | (list left align-right sep right)))) 84 | 85 | (setf *mode-line-timeout* 1) 86 | 87 | (unless (stumpwm::head-mode-line (current-head)) 88 | (toggle-mode-line (current-screen) (current-head)) 89 | (run-commands "stumptray")) 90 | -------------------------------------------------------------------------------- /mouse.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mouse-follow 3 | (:use :cl :stumpwm :hfj :alexandria) 4 | (:export 5 | *mouse-follow-banish-x-offset* 6 | *mouse-follow-banish-y-offset* 7 | disable 8 | enable)) 9 | (in-package :mouse-follow) 10 | 11 | (setf *mouse-focus-policy* :click) 12 | 13 | (defvar *mouse-follow-banish-x-offset* -15 14 | "Negative values mean position from the right.") 15 | 16 | (defvar *mouse-follow-banish-y-offset* -15 17 | "Negative values mean position from the bottom.") 18 | 19 | (defstruct last-change mouse-x mouse-y window frame) 20 | 21 | (defparameter *last-mouse-position* nil) 22 | 23 | (defun wait-for-stable-change (window frame) 24 | "Set a timer that will determine if the current change isn't replaced by 25 | another. If it hasn't, then the pointer will be moved." 26 | (multiple-value-bind (mouse-x mouse-y) 27 | (xlib:global-pointer-position *display*) 28 | (let ((change (make-last-change :mouse-x mouse-x 29 | :mouse-y mouse-y 30 | :window window 31 | :frame frame))) 32 | (setq *last-mouse-position* change) 33 | (run-with-timer 0.15 nil #'wait-for-stable-change-timeout change)))) 34 | 35 | (defun wait-for-stable-change-timeout (change) 36 | "Test that the timeout's change is the last change made and that the mouse 37 | hasn't been moved by other means since then." 38 | (when (eq change *last-mouse-position*) 39 | (multiple-value-bind (mouse-x mouse-y) 40 | (xlib:global-pointer-position *display*) 41 | (when (and (eql (last-change-mouse-x change) mouse-x) 42 | (eql (last-change-mouse-y change) mouse-y)) 43 | (cond ((and (last-change-window change) 44 | (not (mouse-inside-window-p (last-change-window change)))) 45 | (mouse-banish-window (last-change-window change))) 46 | ((and (last-change-frame change) 47 | (not (mouse-inside-frame-p (last-change-frame change)))) 48 | (mouse-banish-frame (last-change-frame change)))))))) 49 | 50 | (defun mouse-banish-frame (frame) 51 | "Banish mouse to corner of frame" 52 | (let* ((group (current-group)) 53 | (min-x (frame-x frame)) 54 | (max-x (+ min-x (frame-width frame))) 55 | (new-x (if (minusp *mouse-follow-banish-x-offset*) 56 | (+ max-x *mouse-follow-banish-x-offset*) 57 | (+ min-x *mouse-follow-banish-x-offset*))) 58 | (min-y (stumpwm::frame-display-y group frame)) 59 | (max-y (+ min-y (stumpwm::frame-display-height group frame))) 60 | (new-y (if (minusp *mouse-follow-banish-y-offset*) 61 | (+ max-y *mouse-follow-banish-y-offset*) 62 | (+ min-y *mouse-follow-banish-y-offset*)))) 63 | (ratwarp (clamp new-x min-x max-x) 64 | (clamp new-y min-y max-y)))) 65 | 66 | (defun mouse-banish-window (window) 67 | "Move mouse pointer to edge of a window." 68 | (let* ((min-x (xlib:drawable-x (window-parent window))) 69 | (max-x (+ min-x (xlib:drawable-width (window-parent window)))) 70 | (new-x (if (minusp *mouse-follow-banish-x-offset*) 71 | (+ max-x *mouse-follow-banish-x-offset*) 72 | (+ min-x *mouse-follow-banish-x-offset*))) 73 | (min-y (xlib:drawable-y (window-parent window))) 74 | (max-y (+ min-y (xlib:drawable-height (window-parent window)))) 75 | (new-y (if (minusp *mouse-follow-banish-y-offset*) 76 | (+ max-y *mouse-follow-banish-y-offset*) 77 | (+ min-y *mouse-follow-banish-y-offset*)))) 78 | (ratwarp (clamp new-x min-x max-x) 79 | (clamp new-y min-y max-y)))) 80 | 81 | ;; Check 82 | 83 | (defun mouse-inside-frame-p (frame) 84 | "Determine if mouse already inside frame." 85 | (multiple-value-bind (mouse-x mouse-y) 86 | (xlib:global-pointer-position *display*) 87 | (let* ((group (current-group)) 88 | (min-x (frame-x frame)) 89 | (min-y (stumpwm::frame-display-y group frame)) 90 | (max-x (+ min-x (frame-width frame))) 91 | (max-y (+ min-y (stumpwm::frame-display-height group frame)))) 92 | (and (<= min-x mouse-x max-x) 93 | (<= min-y mouse-y max-y))))) 94 | 95 | (defgeneric mouse-inside-window-p (window) 96 | (:documentation "Determine if mouse already inside window.") 97 | (:method ((window stumpwm::float-window)) 98 | (multiple-value-bind (mouse-x mouse-y) 99 | (xlib:global-pointer-position *display*) 100 | (let* ((leniency-offset 2) 101 | (x (xlib:drawable-x (window-parent window))) 102 | (w (xlib:drawable-width (window-parent window))) 103 | (min-x (- x stumpwm::*float-window-border* leniency-offset)) 104 | (max-x (+ x w stumpwm::*float-window-border* leniency-offset)) 105 | (y (xlib:drawable-y (window-parent window))) 106 | (h (xlib:drawable-height (window-parent window))) 107 | (min-y (- y stumpwm::*float-window-title-height* leniency-offset)) 108 | (max-y (+ y h stumpwm::*float-window-border* leniency-offset))) 109 | (and (<= min-x mouse-x max-x) 110 | (<= min-y mouse-y max-y))))) 111 | (:method ((window stumpwm::tile-window)) 112 | (let ((frame (stumpwm::window-frame window))) 113 | (mouse-inside-frame-p frame)))) 114 | 115 | ;; Handlers 116 | 117 | (defun mouse-handle-focus-frame (current-frame last-frame) 118 | "Move mouse when moving frames." 119 | (declare (ignore last-frame)) 120 | (wait-for-stable-change nil current-frame)) 121 | 122 | (defun mouse-handle-split-frame (old-frame first-frame second-frame) 123 | "Reposition the mouse when a frame is created." 124 | (declare (ignore old-frame second-frame)) 125 | (wait-for-stable-change (current-window) first-frame)) 126 | 127 | (defun mouse-handle-remove-split (current-frame old-frame) 128 | "Reposition the mouse when a frame is removed." 129 | (declare (ignore old-frame)) 130 | (wait-for-stable-change nil current-frame)) 131 | 132 | (defun mouse-handle-focus-window (current-window last-window) 133 | "Move mouse for floating windows." 134 | (declare (ignore last-window)) 135 | (wait-for-stable-change current-window nil)) 136 | 137 | (defun mouse-handle-focus-group (group old-group) 138 | "Disable sloppy pointer when switching groups to prevent floating windows from 139 | getting stuck and banish to last window or frame." 140 | (declare (ignore old-group)) 141 | (wait-for-stable-change (current-window) (stumpwm::tile-group-current-frame group))) 142 | 143 | ;; Configuration 144 | 145 | (defun disable () 146 | "Disable mouse follows window mode." 147 | (remove-hook *focus-frame-hook* #'mouse-handle-focus-frame) 148 | (remove-hook *split-frame-hook* #'mouse-handle-split-frame) 149 | (remove-hook *remove-split-hook* #'mouse-handle-remove-split) 150 | (remove-hook *focus-window-hook* #'mouse-handle-focus-window) 151 | (remove-hook *focus-group-hook* #'mouse-handle-focus-group)) 152 | 153 | (defun enable () 154 | "Enable mouse follows window mode." 155 | (disable) 156 | (add-hook *focus-frame-hook* #'mouse-handle-focus-frame) 157 | (add-hook *split-frame-hook* #'mouse-handle-split-frame) 158 | (add-hook *remove-split-hook* #'mouse-handle-remove-split) 159 | (add-hook *focus-window-hook* #'mouse-handle-focus-window) 160 | (add-hook *focus-group-hook* #'mouse-handle-focus-group)) 161 | 162 | (enable) 163 | -------------------------------------------------------------------------------- /preload.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | (export '(after-load-conf)) 3 | 4 | (ql:quickload "xembed") 5 | 6 | (defparameter *load-hooks* '()) 7 | 8 | (defun add-local-hook (name f) 9 | "Add a hook for running at the end of a local file." 10 | (push (list name f) *load-hooks*)) 11 | 12 | (defun run-local-hooks (name) 13 | (dolist (l (reverse *load-hooks*)) 14 | (let ((local-name (first l)) 15 | (f (second l))) 16 | (when (string= name local-name) 17 | (funcall f))))) 18 | 19 | (defmacro after-load-conf ((name) &body body) 20 | `(add-local-hook ,name 21 | #'(lambda () 22 | (eval '(progn ,@body))))) 23 | 24 | (defun load-conf (name) 25 | "Load a config file in the *config-path*." 26 | (load (uiop:subpathname* *config-path* name)) 27 | (run-local-hooks name)) 28 | -------------------------------------------------------------------------------- /scratchpad.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage scratchpad 3 | (:use :cl :stumpwm) 4 | (:export #:*default-split-ratio* 5 | #:*default-float-ratio* 6 | #:toggle-split-scratchpad 7 | #:toggle-floating-scratchpad)) 8 | (in-package :scratchpad) 9 | 10 | (defvar *default-split-ratio* 1/2) 11 | 12 | (defvar *default-float-ratio* 1/2) 13 | 14 | (defvar *scratch-floats* '() 15 | "Alist of names to windows for float scratchpads.") 16 | 17 | (defun scratchpad-handle-float-window-destroy (window) 18 | (setf *scratch-floats* (delete window *scratch-floats* 19 | :key #'cdr))) 20 | 21 | (remove-hook *destroy-window-hook* #'scratchpad-handle-float-window-destroy) 22 | (add-hook *destroy-window-hook* #'scratchpad-handle-float-window-destroy) 23 | 24 | (defvar *scratch-splits* '() 25 | "Alist of names to windows for split scratchpads.") 26 | 27 | (defun scratchpad-handle-split-window-destroy (window) 28 | (setf *scratch-splits* (delete window *scratch-splits* 29 | :key #'cdr))) 30 | 31 | (remove-hook *destroy-window-hook* #'scratchpad-handle-split-window-destroy) 32 | (add-hook *destroy-window-hook* #'scratchpad-handle-split-window-destroy) 33 | 34 | (defun maybe-remove-old-split (moved-from-group moved-from-frame) 35 | "Remove old frame if empty." 36 | (let* ((head (stumpwm::frame-head moved-from-group moved-from-frame)) 37 | (tree (stumpwm::tile-group-frame-head moved-from-group head))) 38 | (when (and (null (stumpwm::frame-window moved-from-frame)) 39 | (not (atom tree))) 40 | (remove-split moved-from-group)))) 41 | 42 | (defun resize-by-gravity (window gravity ratio) 43 | (let* ((screen (current-screen)) 44 | (screen-x (stumpwm::screen-x screen)) 45 | (screen-y (stumpwm::screen-y screen)) 46 | (screen-width (stumpwm::screen-width screen)) 47 | (screen-height (stumpwm::screen-height screen)) 48 | 49 | (x-min screen-x) 50 | (x-max (- (+ screen-x screen-width) 51 | (* 2 stumpwm::*float-window-border*))) 52 | 53 | (y-min screen-y) 54 | (y-max (- (+ screen-y screen-height) 55 | stumpwm::*float-window-title-height* 56 | stumpwm::*float-window-border*)) 57 | 58 | (new-x-min x-min) 59 | (new-x-max x-max) 60 | (new-y-min y-min) 61 | (new-y-max y-max) 62 | (x-width (- x-max x-min)) 63 | (x-ratio-length (- x-width (floor (* x-width ratio)))) 64 | (y-width (- y-max y-min)) 65 | (y-ratio-length (- y-width (floor (* y-width ratio))))) 66 | (when (member gravity '(:top :top-right :top-left)) 67 | (decf new-y-max y-ratio-length)) 68 | 69 | (when (member gravity '(:bottom :bottom-right :bottom-left)) 70 | (incf new-y-min y-ratio-length)) 71 | 72 | (when (member gravity '(:left :top-left :bottom-left)) 73 | (decf new-x-max x-ratio-length)) 74 | 75 | (when (member gravity '(:right :top-right :bottom-right)) 76 | (incf new-x-min x-ratio-length)) 77 | 78 | (when (eq gravity :center) 79 | (decf new-y-max (floor (/ y-ratio-length 2))) 80 | (incf new-y-min (floor (/ y-ratio-length 2))) 81 | 82 | (incf new-x-min (floor (/ x-ratio-length 2))) 83 | (decf new-x-max (floor (/ x-ratio-length 2)))) 84 | 85 | (stumpwm::float-window-move-resize window 86 | :x new-x-min :y new-y-min 87 | :width (- new-x-max new-x-min 1) 88 | :height (- new-y-max new-y-min 1)))) 89 | 90 | (defun flatten-direction (current-frame gravity) 91 | "Convert direction list into single direction." 92 | (let ((direction '())) 93 | (when (member gravity '(:top :top-right :top-left)) 94 | (push :above direction)) 95 | (when (member gravity '(:bottom :bottom-right :bottom-left)) 96 | (push :below direction)) 97 | (when (member gravity '(:left :top-left :bottom-left)) 98 | (push :left direction)) 99 | (when (member gravity '(:right :top-right :bottom-right)) 100 | (push :right direction)) 101 | (cond ((and (listp direction) 102 | (= 1 (length direction))) 103 | (first direction)) 104 | ((listp direction) 105 | (let* ((w (frame-width current-frame)) 106 | (h (frame-height current-frame)) 107 | (allowed (if (< w h) 108 | '(:above :below) 109 | '(:left :right)))) 110 | (or (first (intersection allowed direction)) 111 | :below))) 112 | (t 113 | direction)))) 114 | 115 | (defun scratchpad-split-frame (gravity ratio group current-frame current-window 116 | scratchpad-window moved-from-group moved-from-frame) 117 | "Create a new frame and place the scratchpad in it." 118 | (let* ((decided-direction (flatten-direction current-frame gravity)) 119 | (swapped (member decided-direction '(:above :left))) 120 | (dir (if (member decided-direction '(:below :above)) :row :column)) 121 | (r (if swapped ratio (- 1 ratio))) 122 | (old-num (stumpwm::frame-number current-frame)) 123 | (new-num (stumpwm::split-frame group dir r)) 124 | (target-frame (stumpwm::frame-by-number group (if swapped old-num new-num))) 125 | (original-frame (stumpwm::frame-by-number group (if swapped new-num old-num)))) 126 | (move-window-to-group scratchpad-window group) 127 | (maybe-remove-old-split moved-from-group moved-from-frame) 128 | (when swapped 129 | (stumpwm::migrate-frame-windows group target-frame original-frame)) 130 | (stumpwm::pull-window scratchpad-window target-frame nil) 131 | (when current-window 132 | (stumpwm::pull-window current-window original-frame nil)) 133 | (stumpwm::focus-frame group target-frame) 134 | (stumpwm::sync-all-frame-windows group))) 135 | 136 | (defun toggle-split-scratchpad (name cmd &key (ratio *default-split-ratio*) 137 | (gravity :bottom-right) 138 | (all-groups *run-or-raise-all-groups*) 139 | (all-screens *run-or-raise-all-screens*)) 140 | "Create or toggle display of a named scratchpad. Display by creating a frame." 141 | (let ((found (member name *scratch-splits* 142 | :key #'car 143 | :test #'string=))) 144 | (cond ((and found 145 | (not (typep (cdr (car found)) 146 | 'stumpwm::tile-window))) 147 | ;; Type not correct! 148 | nil) 149 | (found 150 | (let* ((window (cdr (car found))) 151 | (group (current-group)) 152 | (current-frame (stumpwm::tile-group-current-frame group)) 153 | (current-window (group-current-window group)) 154 | (moved-from-frame (stumpwm::window-frame window)) 155 | (moved-from-group (window-group window))) 156 | (cond 157 | ;; Currently focused on scratchpad; Hide it 158 | ((and (eq current-frame moved-from-frame) 159 | (eq window (stumpwm::frame-window current-frame))) 160 | (remove-split)) 161 | ;; Scratchpad is visible, move to it 162 | ((and (eq moved-from-group group) (window-visible-p window)) 163 | (stumpwm::focus-frame moved-from-group moved-from-frame)) 164 | ;; Current frame is empty, just display it 165 | ((null (stumpwm::frame-window current-frame)) 166 | (move-window-to-group window group) 167 | (maybe-remove-old-split moved-from-group moved-from-frame)) 168 | ;; Scratchpad needs a new frame 169 | (t (scratchpad-split-frame gravity 170 | ratio 171 | group 172 | current-frame 173 | current-window 174 | window 175 | moved-from-group 176 | moved-from-frame))))) 177 | (t 178 | (hfj:with-new-window (window cmd) 179 | :new 180 | (push (cons name window) *scratch-splits*)))))) 181 | 182 | (defun toggle-floating-scratchpad (name cmd &key initial-gravity (ratio *default-float-ratio*)) 183 | "Create or toggle display of a named scratchpad. Display by floating window." 184 | (let ((found (member name *scratch-floats* 185 | :key #'car 186 | :test #'string=))) 187 | (cond ((and found 188 | (not (typep (cdr (car found)) 189 | 'stumpwm::float-window))) 190 | ;; Type not correct! 191 | nil) 192 | (found 193 | (let ((window (cdr (car found)))) 194 | (cond ((eq (current-window) window) 195 | (stumpwm::hide-window window)) 196 | ((stumpwm::window-in-current-group-p window) 197 | (focus-window window t)) 198 | (t 199 | (move-window-to-group window (current-group)) 200 | (focus-window window t))))) 201 | (t 202 | (hfj:with-new-window (window cmd) 203 | :new 204 | (push (cons name window) *scratch-floats*) 205 | :focus 206 | (stumpwm::float-window window (current-group)) 207 | (cond (initial-gravity 208 | (resize-by-gravity window initial-gravity ratio)))))))) 209 | 210 | (defcommand scratchpad-float (name cmd gravity) ((:string "Name: ") 211 | (:string "Command: ") 212 | (:gravity "Side: ")) 213 | (toggle-floating-scratchpad name cmd 214 | :initial-gravity gravity)) 215 | -------------------------------------------------------------------------------- /session.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | 3 | (defmacro if-sure (&body body) 4 | `(when (equal :yes (second (select-from-menu (current-screen) 5 | '(("no" :no) ("yes" :yes)) 6 | "Are you sure?"))) 7 | ,@body)) 8 | 9 | (flet ((finalize-session () 10 | "mktemp and set env var SHUTDOWN_FILE to catch fatal errors in stumpwm and 11 | restart instead of logging out, except when we really want to. 12 | 13 | Example: 14 | export SHUTDOWN_FILE=$(mktemp) 15 | while [[ -e $SHUTDOWN_FILE ]]; do 16 | echo \"Starting: $(date)\" >> ~/tmp/stumpwm.log 17 | ~/opt/stumpwm/bin/stumpwm >> ~/tmp/stumpwm.log 2>&1 18 | status=$? 19 | echo \"Shutdown with: ${status} on $(date)\" >> ~/tmp/stumpwm.log 20 | done 21 | " 22 | (when-let* ((shutdown-file (uiop:getenv "SHUTDOWN_FILE")) 23 | (file (probe-file shutdown-file))) 24 | (delete-file file)))) 25 | (defcommand session-menu () () 26 | (let* ((menu '(("0. cancel" "echo cancelled") 27 | ("1. log out" :quit) 28 | ("2. switch user" :switch-user) 29 | ("3. reboot" :reboot) 30 | ("4. poweroff" :poweroff))) 31 | (selection (select-from-menu (current-screen) menu "Choose action:"))) 32 | (cond ((null selection) 33 | nil) 34 | ((stringp (second selection)) 35 | (run-commands (second selection))) 36 | (t (case (second selection) 37 | (:quit 38 | (if-sure 39 | (finalize-session) 40 | (run-commands "quit"))) 41 | (:switch-user 42 | (if-sure (run-shell-command "dm-tool switch-to-greeter"))) 43 | (:reboot 44 | (if-sure 45 | (finalize-session) 46 | (run-shell-command "systemctl reboot"))) 47 | (:poweroff 48 | (if-sure 49 | (finalize-session) 50 | (run-shell-command "systemctl poweroff"))) 51 | (otherwise 52 | (run-commands (format nil "echo Unknown selection: ~S" (second selection)))))))))) 53 | -------------------------------------------------------------------------------- /window.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hfj) 2 | (export '(get-x 3 | get-y 4 | get-width 5 | get-height 6 | with-new-window)) 7 | 8 | (defvar *current-selected-window* nil) 9 | (defvar *last-selected-window* nil) 10 | (defvar *stable-focus-window-hook-timer* nil) 11 | 12 | (defun window-handle-focus-window-hook-timeout (window) 13 | "Handle timeout from window-handle-focus-window-hook. Log the current new 14 | stable window and move current to last." 15 | (cancel-timer *stable-focus-window-hook-timer*) 16 | (setq *stable-focus-window-hook-timer* nil) 17 | (when (not (eq window *current-selected-window*)) 18 | (setq *last-selected-window* *current-selected-window*) 19 | (setq *current-selected-window* window))) 20 | 21 | (defun window-handle-focus-window-hook (window last-window) 22 | "Track window focus changes in order to set *last-selected-window*." 23 | (declare (ignore last-window)) 24 | (when *stable-focus-window-hook-timer* 25 | (cancel-timer *stable-focus-window-hook-timer*)) 26 | (setq *stable-focus-window-hook-timer* 27 | (run-with-timer 0.3 nil #'window-handle-focus-window-hook-timeout window))) 28 | 29 | (defcommand switch-to-previous-window () () 30 | (when *last-selected-window* 31 | (stumpwm::focus-all *last-selected-window*) 32 | (rotatef *last-selected-window* *current-selected-window*))) 33 | 34 | (add-hook *focus-window-hook* #'window-handle-focus-window-hook) 35 | 36 | (defgeneric get-x (window) 37 | (:documentation "Generic get x position")) 38 | (defgeneric get-y (window) 39 | (:documentation "Generic get y position")) 40 | (defgeneric get-width (window) 41 | (:documentation "Generic get width")) 42 | (defgeneric get-height (window) 43 | (:documentation "Generic get height position")) 44 | 45 | (defmethod get-x ((window xlib:window)) 46 | (xlib:drawable-x window)) 47 | (defmethod get-y ((window xlib:window)) 48 | (xlib:drawable-y window)) 49 | (defmethod get-width ((window xlib:window)) 50 | (xlib:drawable-width window)) 51 | (defmethod get-height ((window xlib:window)) 52 | (xlib:drawable-height window)) 53 | 54 | (defmethod get-x ((frame stumpwm::frame)) 55 | (frame-x frame)) 56 | (defmethod get-y ((frame stumpwm::frame)) 57 | (frame-y frame)) 58 | (defmethod get-width ((frame stumpwm::frame)) 59 | (frame-width frame)) 60 | (defmethod get-height ((frame stumpwm::frame)) 61 | (frame-height frame)) 62 | 63 | (defmethod get-x ((window stumpwm::window)) 64 | (get-x (window-parent window))) 65 | (defmethod get-y ((window stumpwm::window)) 66 | (get-y (window-parent window))) 67 | (defmethod get-width ((window stumpwm::window)) 68 | (window-width window)) 69 | (defmethod get-height ((window stumpwm::window)) 70 | (window-height window)) 71 | 72 | (defcommand windowlist-all () () 73 | (let* ((windows (sort (copy-list (stumpwm::all-windows)) #'string-lessp :key #'stumpwm::window-name)) 74 | (window (stumpwm::select-window-from-menu windows "%12c: %50t"))) 75 | (when window 76 | (stumpwm::focus-all window)))) 77 | 78 | (defcommand iresize-hfj () () 79 | (ratwarp 0 0) 80 | (run-commands "iresize")) 81 | 82 | (defun run-and-act-on-new-window (cmd props timeout on-create-f on-focus-f) 83 | "Run a command, setup a handler to apply a function to the new window once it's open." 84 | (let* (focus-window-handler 85 | new-window-handler 86 | (timer (run-with-timer timeout nil 87 | #'(lambda () 88 | ;; Remove hooks after period of time should something go wrong. 89 | (when focus-window-handler 90 | (remove-hook *focus-window-hook* focus-window-handler)) 91 | (when new-window-handler 92 | (remove-hook *new-window-hook* new-window-handler)))))) 93 | (setf new-window-handler 94 | #'(lambda (new-window) 95 | (when (apply 'stumpwm::window-matches-properties-p new-window props) 96 | (remove-hook *new-window-hook* new-window-handler) 97 | (setf new-window-handler nil) 98 | (setf focus-window-handler 99 | #'(lambda (focused-window last-focused-window) 100 | (declare (ignore last-focused-window)) 101 | (when (eq new-window focused-window) 102 | (remove-hook *focus-window-hook* focus-window-handler) 103 | (setf focus-window-handler nil) 104 | (cancel-timer timer) 105 | (when on-focus-f 106 | (funcall on-focus-f new-window))))) 107 | (add-hook *focus-window-hook* focus-window-handler) 108 | (when on-create-f 109 | (funcall on-create-f new-window))))) 110 | (add-hook *new-window-hook* new-window-handler) 111 | (run-shell-command cmd))) 112 | 113 | (defmacro with-new-window ((window cmd &key properties (timeout 30)) 114 | &body body) 115 | "Execute command, on next new window matching properties, run the body. If no 116 | properties given, next new window will be acted on. 117 | 118 | By default, code will run in *focus-window-hook* handler, but can also run in 119 | *new-window-hook* handler by using keyword :new. Return to focus hook with 120 | :focus." 121 | (let ((state 'config) 122 | (init '()) 123 | (config '())) 124 | (map nil #'(lambda (e) 125 | (case e 126 | (:focus (setf state 'config)) 127 | (:new (setf state 'init)) 128 | (t (ecase state 129 | (init (push e init)) 130 | (config (push e config)))))) 131 | body) 132 | `(run-and-act-on-new-window ,cmd ,properties ,timeout 133 | #'(lambda (,window) 134 | ,@(reverse init)) 135 | #'(lambda (,window) 136 | ,@(reverse config))))) 137 | --------------------------------------------------------------------------------