;;;; Function-only upgrade: Activity numbering changes, not the live world.
(in-package #:cl-user)

(defun lime-activity-order-definitions ()
  (let* ((*package* (find-package :lime.x11)) (*read-eval* nil)
         (names '(lime.x11::%navigation-activity-slots lime.x11::%navigation-state
                  lime.x11:backend-set-activity-slot lime.x11::%navigation-read-data))
         (found nil))
    (with-open-file (in #p"/home/adan/code/common-lisp/lime/src/x11/navigation.lisp")
      (loop for form = (read in nil :eof) until (eq form :eof)
            when (and (consp form) (eq (first form) 'defun) (member (second form) names))
              do (push form found)))
    (assert (= (length names) (length found)))
    (mapcar (lambda (name) (or (find name found :key #'second) (error "Missing ~S" name))) names)))

(defun lime-upgrade-live-activity-order (backup-path)
  (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* ((session (lime.x11::%session-snapshot backend))
           (world (lime.x11:x11-backend-world backend))
           (before (getf session :world))
           (before-nav (getf session :navigation))
           (state (lime.x11::%navigation-state backend))
           (old-state (lime.x11::copy-navigation-state state))
           (config (lime.x11::x11-backend-configuration backend))
           (definitions (lime-activity-order-definitions))
           (old-functions (mapcar (lambda (form)
                                    (let ((name (second form)))
                                      (cons name (and (fboundp name) (fdefinition name))))) definitions)))
      (when (probe-file backup-path) (error "Refusing to overwrite the pre-upgrade backup."))
      (let ((store (lime.persistence:open-session-store backup-path)))
        (unwind-protect (lime.persistence:write-session-store store session)
          (lime.persistence:close-session-store store)))
      (handler-case
          (progn
            (dolist (definition definitions) (eval definition))
            ;; The existing cache already observed this model revision; force
            ;; one metadata-only synchronization using the new slot policy.
            (setf (lime.x11::navigation-state-observed-revision state) nil)
            (let ((after-nav (lime.x11::%navigation-snapshot backend)))
              (assert (equal (mapcar #'first (getf before-nav :activities))
                             (mapcar #'first (getf after-nav :activities))))
              (assert (equal (loop for n from 1 to (length (getf after-nav :activities)) collect n)
                             (mapcar #'second (getf after-nav :activities))))
              (assert (equal (getf before-nav :views) (getf after-nav :views)))
              (assert (equal (getf before-nav :resume) (getf after-nav :resume)))
              (assert (equalp before (lime.persistence:snapshot-world world)))
              (assert (eq config (lime.x11::x11-backend-configuration backend)))
              (lime.x11::render-head-bars backend)
              (xlib:display-finish-output (lime.x11::x11-backend-display backend))
              (assert (lime.core:validate-world world))
              (list :upgraded t :world-unchanged t :views-unchanged t :bar-order-unchanged t
                    :activities (getf after-nav :activities) :backup backup-path)))
        (error (condition)
          (dolist (entry old-functions)
            (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry))))
          (setf (gethash backend lime.x11::*backend-navigation-states*) old-state)
          (ignore-errors (lime.x11::render-head-bars backend))
          (error condition))))))