add frame-mode-line-mode to have a mode line per frame

README.org

@@ -85,6 +85,7 @@ Advertise your module here, open a PR and include a org-mode link!
 - [[./media/stumpwm-mixer/README.md][stumpwm-mixer]] :: Interface to FreeBSD's built-in sound mixer
 - [[./media/stumpwm-sndioctl/README.md][stumpwm-sndioctl]] :: Interface to OpenBSD's sndioctl from StumpWM.
 ** Minor Modes
+- [[./minor-mode/fml/README.md][swm-frame-mode-line]] :: Mode line per frame
 - [[./minor-mode/grabbable-modifier-keys/README.md][grabbable-modifier-keys]] :: Allow StumpWM users to grab modifier keys and bind them
 - [[./minor-mode/mpd/README.org][mpd]] :: Displays information about the music player daemon (MPD).
 - [[./minor-mode/notifications/README.org][notifications]] :: A notification library that sends notifications to the modeline via stumpish or from stumpwm itself.

minor-mode/fml/README.md

@@ -0,0 +1,9 @@
+# swm-frame-mode-line
+
+This implements a mode line per frame. Enable/disable it with the command
+`frame-mode-line-mode`
+
+## License
+
+GPLv3
+

minor-mode/fml/package.lisp

@@ -0,0 +1,4 @@
+;;;; package.lisp
+
+(defpackage #:swm-frame-mode-line
+  (:use #:cl))

minor-mode/fml/swm-frame-mode-line.asd

@@ -0,0 +1,11 @@
+;;;; swm-frame-mode-line.asd
+
+(asdf:defsystem #:swm-frame-mode-line
+  :description "Mode line per frame"
+  :author "szos at posteo dot net"
+  :license  "GPLv3"
+  :version "0.0.1"
+  :serial t
+  :depends-on (#:stumpwm)
+  :components ((:file "package")
+               (:file "swm-frame-mode-line")))

minor-mode/fml/swm-frame-mode-line.lisp

@@ -0,0 +1,254 @@
+;;;; swm-frame-mode-line.lisp
+
+(in-package #:swm-frame-mode-line)
+
+;; We need a new struct because we have to track the mode lines parent frame
+(defstruct (fml (:include stumpwm::mode-line)
+                (:constructor %make-fml))
+  frame)
+
+;; And this will be a mixin for tracking the cc, and all cc objects.
+(defclass frame-mode-line ()
+  ((fml-ml :initform nil :accessor frame-mode-line-fml)
+   (fml-cc :initform nil :accessor frame-mode-line-cc)
+   (all-cc :initform nil :accessor frame-mode-line-all-cc :allocation :class)))
+
+(defparameter *frame-mode-line-format* '("%f")
+  "The frame mode line format string/list")
+
+(stumpwm::add-screen-mode-line-formatter #\f 'format-frame-window-list)
+(defun format-frame-window-list (mode-line)
+  "Format the windowlist of a frame. This should only be called for fml objects"
+  (format nil "~{~a~^ ~}"
+          (mapcar (lambda (w)
+                    (stumpwm:format-with-on-click-id 
+                     (let ((str (stumpwm:format-expand stumpwm:*window-formatters*
+                                                       stumpwm:*window-format*
+                                                       w)))
+                       (if (eq w (stumpwm::frame-window (fml-frame mode-line)))
+                           (stumpwm::fmt-highlight str)
+                           str))
+                     :ml-on-click-focus-window
+                     (stumpwm::window-id w)))
+                  (stumpwm::sort1
+                   (stumpwm::frame-windows (stumpwm::mode-line-current-group
+                                            mode-line)
+                                           (if (typep mode-line 'fml)
+                                               (fml-frame mode-line)
+                                               (stumpwm::tile-group-current-frame
+                                                (stumpwm::mode-line-current-group
+                                                 mode-line))))
+                   #'< :key #'stumpwm::window-number))))
+
+(defun rendered-size-y-only (strings cc)
+  "Return the y height of the rendered strings"
+  (nth-value 1 (stumpwm::rendered-size strings cc)))
+
+(defun make-fml (screen frame)
+  "Create an FML mode line"
+  (let* ((window (stumpwm::make-mode-line-window screen))
+         (gc (stumpwm::make-mode-line-gc window screen))
+         (cc (stumpwm::make-mode-line-cc window screen gc))
+         (ml (%make-fml :window window
+                        :screen screen
+                        :head (stumpwm::frame-head
+                               (stumpwm::current-group)
+                               frame)
+                        :format ""
+                        :cc cc
+                        :frame frame)))
+    ml))
+
+(defun setup-fml-window (frame cc text-height)
+  "Set up the window to have the correct height"
+  (let ((win (stumpwm::ccontext-win cc))
+        (yoffset 0)
+        (xoffset 0))
+    (xlib:with-state (win)
+      (setf (xlib:drawable-height win) text-height 
+            (xlib:drawable-width win) (- (stumpwm::frame-width frame)
+                                          (* 2 xoffset)
+                                          (* 2 stumpwm::*mode-line-border-width*))
+            (xlib:window-priority win) :above
+            (xlib:drawable-y win)
+            (+ (- (stumpwm::frame-display-y (stumpwm:current-group)
+                                            frame)
+                   (rendered-size-y-only
+                    (generate-frame-windows-string
+                     (stumpwm:current-group)
+                     frame)
+                    (frame-mode-line-cc frame)))
+                yoffset)
+            (xlib:drawable-x win) (+ (stumpwm::frame-x frame) xoffset)))
+    (xlib:map-window win)
+    (xlib:display-finish-output stumpwm::*display*)))
+
+(defun display-frame-mode-line (frame &optional force)
+  "actually do the displaying of the mode line."
+  (multiple-value-bind (width height)
+      (stumpwm::rendered-size (stumpwm::mode-line-format
+                               (frame-mode-line-fml frame))
+                              (frame-mode-line-cc frame))
+    (declare (ignore width))
+    (setup-fml-window frame (frame-mode-line-cc frame) height))
+  (let* ((stumpwm::*current-mode-line-formatters*
+           stumpwm::*screen-mode-line-formatters*)
+         (stumpwm::*current-mode-line-formatter-args*
+           (list (frame-mode-line-fml frame)))
+         (str
+           (handler-case (stumpwm::mode-line-format-string
+                          (frame-mode-line-fml frame))
+             (error (c)
+               (format nil "Unable to expand mode line format string: ~S" c)))))
+    (flet ((resize-and-render (string)
+             (setf (stumpwm::mode-line-contents (frame-mode-line-fml frame))
+                   string)
+             (stumpwm::render-strings (stumpwm::mode-line-cc
+                                       (frame-mode-line-fml frame))
+                                      stumpwm::*mode-line-pad-x*
+                                      stumpwm::*mode-line-pad-y*
+                                      (stumpwm::split-string string
+                                                             (string #\Newline))
+                                      ()
+                                      :ml (frame-mode-line-fml frame))
+             (when (stumpwm::mode-line-new-bounds (frame-mode-line-fml frame))
+               (setf (stumpwm::mode-line-on-click-bounds
+                      (frame-mode-line-fml frame))
+                     (reverse (stumpwm::mode-line-new-bounds
+                               (frame-mode-line-fml frame)))))))
+      (handler-case
+          (when (or force (not (string= (stumpwm::mode-line-contents
+                                         (frame-mode-line-fml frame))
+                                        str)))
+            (resize-and-render str))
+        (error (c)
+          (resize-and-render
+           (format nil "Unable to render mode line: ~S" c)))))))
+
+(defun hide-frame-mode-line (frame)
+  (xlib:unmap-window (stumpwm::ccontext-win (frame-mode-line-cc frame))))
+
+(defmethod stumpwm::sync-frame-windows :after (group (frame frame-mode-line))
+  (display-frame-mode-line frame))
+
+(defmethod (setf stumpwm::frame-window) :after (new (frame frame-mode-line))
+  (display-frame-mode-line frame))
+
+(defmethod (setf stumpwm::window-frame) :around (frame (win stumpwm::tile-window))
+  (let ((f (ignore-errors (stumpwm::window-frame win))))
+    (call-next-method)
+    (when (typep f 'frame-mode-line)
+      (display-frame-mode-line f))))
+
+(defmethod stumpwm::frame-display-height :around (group (frame frame-mode-line))
+  (let ((h (call-next-method)))
+    (- h (rendered-size-y-only (generate-frame-windows-string
+                                (stumpwm:current-group)
+                                frame)
+                               (frame-mode-line-cc frame)))))
+
+(defmethod stumpwm::frame-display-y :around (group (frame frame-mode-line))
+  (let ((y (or (ignore-errors (call-next-method))
+               (stumpwm::frame-y frame))))
+    (+ y (rendered-size-y-only (generate-frame-windows-string
+                                (stumpwm:current-group)
+                                frame)
+                               (frame-mode-line-cc frame)))))
+
+(defun adjust-windows-for-frame (frame)
+  (when (stumpwm::frame-window frame)
+    (let* ((group (stumpwm::window-group (stumpwm::frame-window frame)))
+           (windows (stumpwm::frame-windows group frame)))
+      (mapc #'stumpwm::maximize-window windows))))
+
+(defun fml-killwins (l frame)
+  (declare (ignore l))
+  (when (typep frame 'frame-mode-line)
+    (setf (frame-mode-line-all-cc frame) (remove (frame-mode-line-cc frame)
+                                                 (frame-mode-line-all-cc frame)))
+    (xlib:unmap-window (stumpwm::ccontext-win (frame-mode-line-cc frame)))
+    (xlib:destroy-window (stumpwm::ccontext-win (frame-mode-line-cc frame)))))
+
+(stumpwm::add-hook stumpwm::*remove-split-hook* 'fml-killwins)
+
+(defun fml-focus-group (new old)
+  (declare (ignore old))
+  (when (and (stumpwm:minor-mode-enabled-p 'frame-mode-line-bar)
+             (typep new 'stumpwm::tile-group))
+    (mapc (lambda (f)
+            (display-frame-mode-line f))
+          (alexandria:flatten (stumpwm::tile-group-frame-tree new)))))
+
+(stumpwm:define-minor-mode frame-mode-line-bar
+    (frame-mode-line stumpwm:minor-mode)
+  ()
+  (:global t)
+  (:scope :frame-excluding-head)
+  (:lighter "FML")
+  (:interactive frame-mode-line-mode))
+
+(define-frame-mode-line-bar-command update-frame-mode-line (&rest rest) ()
+  "explicitly update the frame mode line"
+  (declare (ignore rest))
+  (let ((obj (stumpwm::tile-group-current-frame (stumpwm:current-group))))
+    (display-frame-mode-line obj)))
+
+(defmethod update-instance-for-different-class :after
+    (prev (obj frame-mode-line-bar) &rest rest)
+  (declare (ignore prev rest))
+  (let ((fml-ml (make-fml (stumpwm::current-screen) obj)))
+    (setf (frame-mode-line-cc obj) (stumpwm::mode-line-cc fml-ml)
+          (frame-mode-line-fml obj) fml-ml
+          (stumpwm::mode-line-format fml-ml) (list *frame-mode-line-format*)))
+  (push (frame-mode-line-cc obj) (frame-mode-line-all-cc obj))
+  (adjust-windows-for-frame obj)
+  (when (member obj (stumpwm::flatten
+                     (stumpwm::tile-group-frame-tree (stumpwm:current-group))))
+    (display-frame-mode-line obj)))
+
+(defmethod stumpwm:autodisable-minor-mode :after ((mode (eql 'frame-mode-line-bar))
+                                                  obj)
+  (adjust-windows-for-frame obj))
+
+(defmethod stumpwm:autodisable-minor-mode :before ((mode (eql 'frame-mode-line-bar))
+                                           (obj frame-mode-line-bar))
+  (setf (frame-mode-line-all-cc obj) (remove (frame-mode-line-cc obj)
+                                             (frame-mode-line-all-cc obj)))
+  (xlib:unmap-window (stumpwm::ccontext-win (frame-mode-line-cc obj)))
+  (xlib:destroy-window (stumpwm::ccontext-win (frame-mode-line-cc obj))))
+
+(defun fml-change-group (new old)
+  (when (typep old 'stumpwm::tile-group)
+    (map nil #'hide-frame-mode-line
+         (alexandria:flatten (stumpwm::tile-group-frame-tree old))))
+  (when (typep new 'stumpwm::tile-group)
+    (map nil #'display-frame-mode-line
+         (alexandria:flatten (stumpwm::tile-group-frame-tree new)))))
+
+(defun fml-setup-hook-fn (mode obj)
+  (declare (ignore mode obj))
+  (stumpwm:add-hook stumpwm:*focus-group-hook* 'fml-change-group))
+
+(stumpwm:add-hook *frame-mode-line-bar-hook* 'fml-setup-hook-fn)
+
+(defun fml-teardown-hook-fn (mode obj)
+  (declare (ignore mode obj))
+  (stumpwm:remove-hook stumpwm:*focus-group-hook* 'fml-change-group))
+
+(stumpwm:add-hook *frame-mode-line-bar-destroy-hook* 'fml-teardown-hook-fn)
+
+(defun autoadjust-windows-on-fml-disable (minor-mode object)
+  (when (eql minor-mode 'frame-mode-line-bar)
+    (adjust-windows-for-frame object)))
+
+(stumpwm:add-hook stumpwm:*minor-mode-disable-hook*
+                  'autoadjust-windows-on-fml-disable)
+
+(defun kill-all-fml-wins (mode obj)
+  (declare (ignore mode))
+  (loop for cc in (frame-mode-line-all-cc obj)
+        do (xlib:unmap-window (stumpwm::ccontext-win cc))
+           (xlib:destroy-window (stumpwm::ccontext-win cc)))
+  (setf (frame-mode-line-all-cc obj) nil))
+
+(stumpwm:add-hook *frame-mode-line-bar-destroy-hook* 'kill-all-fml-wins)