Initial Lime window manager

work/upgrade-live-activity-bar.lisp

@@ -0,0 +1,83 @@
+;;;; Narrow UI-only hotload. No model migration or application operations.
+(in-package #:cl-user)
+
+(defun lime-activity-bar-definitions ()
+  (let ((manifest
+          '(("src/x11/bar.lisp" "%BAR-PRESENTATION-LABEL" "%BAR-ACTIVITY-ENTRIES")
+            ("src/x11/ui.lisp" "%UI-REQUEST-VIEW-ACTIVATION" "%UI-ACTIVITY-CANDIDATES"
+             "%UI-VIEW-UPDATE-CONTEXT-VALID-P" "%UI-CONFIRM-VIEW-UPDATE-RESULT"
+             "%UI-VIEW-UPDATE-PICKER-RESULT" "%UI-UPDATE-CURRENT-VIEW-CANDIDATE"
+             "%UI-COLLISION-CHOICE-CANDIDATES"
+             "%UI-KEY-PATH" "BACKEND-OPEN-VIEW-UPDATE-PICKER")
+            ("src/x11/default-bindings.lisp" "INSTALL-DEFAULT-KEYBINDINGS")))
+        (definitions nil))
+    (dolist (entry manifest)
+      (destructuring-bind (file &rest names) entry
+        (let* ((*package* (find-package :lime.x11)) (*read-eval* nil)
+               (symbols (mapcar (lambda (name) (intern name *package*)) names))
+               (found nil))
+          (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/"))
+            (loop for form = (read in nil :eof) until (eq form :eof)
+                  when (and (consp form) (eq (first form) 'defun) (member (second form) symbols))
+                    do (push form found)))
+          (assert (= (length symbols) (length found)))
+          (dolist (symbol symbols) (assert (find symbol found :key #'second)))
+          (setf definitions (append definitions
+                                    (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols))))))
+    definitions))
+
+(defun lime-upgrade-live-activity-bar ()
+  (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process."))
+  (lime.dev:with-development-backend (backend)
+    (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*)
+                 (not (lime.dev::development-session-paused-p lime.dev:*development-session*)))
+      (error "Lime is not running normally."))
+    (when (or (lime.x11::x11-backend-pointer-drag backend)
+              (lime.x11::x11-backend-ui-session backend))
+      (error "Close the menu or finish the drag before upgrading."))
+    (let* ((world (lime.x11:x11-backend-world backend))
+           (before (lime.persistence:snapshot-world world))
+           (command (lime.x11:find-configured-command backend 'update-view))
+           (old-label (lime.x11:lime-command-label command))
+           (old-detail (lime.x11:lime-command-description command))
+           (old-action (lime.x11:lime-command-action command))
+           (config (lime.x11::x11-backend-configuration backend))
+           (bindings (lime.x11:list-keybindings backend))
+           (definitions (lime-activity-bar-definitions))
+           (old-functions
+             (mapcar (lambda (form)
+                       (let ((name (second form)))
+                         (cons name (and (fboundp name) (fdefinition name)))))
+                     definitions)))
+      (assert (equal "/home/adan/.config/lime/config.lisp"
+                     (lime.x11::x11-backend-configuration-source backend)))
+      (assert (eq old-action (fdefinition 'lime.x11:backend-update-current-view)))
+      (handler-case
+          (progn
+            (dolist (definition definitions) (eval definition))
+            (export 'lime.x11::backend-open-view-update-picker :lime.x11)
+            ;; Bindings resolve the configured command by id at dispatch, so
+            ;; replacing these three fields needs no regrab/provider restart.
+            (setf (lime.x11:lime-command-label command) "Update saved view..."
+                  (lime.x11:lime-command-description command) "Choose a saved arrangement to replace; confirm its name"
+                  (lime.x11:lime-command-action command)
+                  (fdefinition 'lime.x11::backend-open-view-update-picker))
+            (lime.x11::render-head-bars backend)
+            (xlib:display-finish-output (lime.x11::x11-backend-display backend))
+            (assert (equalp before (lime.persistence:snapshot-world world)))
+            (assert (eq config (lime.x11::x11-backend-configuration backend)))
+            (assert (equal bindings (lime.x11:list-keybindings backend)))
+            (assert (lime.core:validate-world world))
+            (list :upgraded t :world-unchanged t :bindings-unchanged t
+                  :function-count (length definitions)
+                  :bars (loop for id in (lime.x11:backend-head-ids backend)
+                              collect (list id (lime.x11::%bar-presentation-label backend id)))
+                  :update-command (lime.x11:lime-command-label command)))
+        (error (condition)
+          (setf (lime.x11:lime-command-label command) old-label
+                (lime.x11:lime-command-description command) old-detail
+                (lime.x11:lime-command-action command) old-action)
+          (dolist (entry old-functions)
+            (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry))))
+          (ignore-errors (lime.x11::render-head-bars backend))
+          (error condition))))))