(in-package #:lime.x11.test) (in-suite lime-x11-suite) (lime.config:defconfiguration numbered-navigation-fixture (:navigation-keys)) (test numbered-navigation-expands-to-configurable-ordinary-bindings (let ((config numbered-navigation-fixture)) (is (= 20 (length (lime-configuration-commands config)))) (is (= 20 (length (lime-configuration-bindings config)))) (is (eq config (lime.x11::%validate-lime-configuration config))) (dolist (kind '(:activity :view)) (loop for n from 1 to 10 for key across "1234567890" do (let* ((id (intern (format nil "NAVIGATE-~A-~D" kind n) :keyword)) (binding (find id (lime-configuration-bindings config) :key #'configuration-binding-command-id))) (is (eql key (configuration-binding-key binding))) (is (equal (if (eq kind :view) '(:mod-4 :shift) '(:mod-4)) (configuration-binding-modifiers binding))))))) (signals error (macroexpand-1 '(lime.config:defconfiguration invalid-navigation (:navigation-keys :typo t))))) (test activity-positions-compact-while-view-slots-stay-local-and-stable (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) (create-activity world "scratch" "Scratch") (create-activity world "chill" "Chill") (create-view world "chill/code" "chill" "Code" nil) (let ((before (lime.persistence:snapshot-world world))) (is (= 1 (backend-activity-slot backend "scratch"))) (is (= 2 (backend-activity-slot backend "chill"))) (is (= 3 (backend-activity-slot backend "development"))) (is (= 1 (backend-view-slot backend "development/code"))) (is (= 1 (backend-view-slot backend "chill/code"))) (backend-set-activity-slot backend "development" 1) (is (= 1 (backend-activity-slot backend "development"))) (is (= 3 (backend-activity-slot backend "scratch"))) (is (equalp before (lime.persistence:snapshot-world world)))) (delete-activity world "chill") (is (= 2 (backend-activity-slot backend "scratch"))) (create-activity world "new" "A new task") (is (= 3 (backend-activity-slot backend "new"))) (create-view world "development/docs" "development" "Docs" nil) (is (= 2 (backend-view-slot backend "development/docs"))) (backend-set-view-slot backend "development/docs" 1) (is (= 1 (backend-view-slot backend "development/docs"))) (is (= 2 (backend-view-slot backend "development/code"))) (signals invalid-transition (backend-set-activity-slot backend "new" 0)) (signals invalid-transition (backend-set-activity-slot backend "new" 4)) (loop for n from 1 to 12 do (create-activity world (format nil "extra~D" n) "Extra")) (is (= 15 (length (getf (backend-navigation-slots backend) :activities)))) (is (null (backend-view-slot backend "chill/code"))) (let ((before (lime.persistence:snapshot-world world))) (is (null (backend-select-activity-slot backend 999))) (is (null (backend-select-view-slot backend 999))) (is (equalp before (lime.persistence:snapshot-world world)))))) (test navigation-persistence-validates-scoped-uniqueness-and-resume-targets (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) (create-activity world "chill" "Chill") (create-view world "chill/code" "chill" "Code" nil) (backend-set-activity-slot backend "development" 2) (backend-set-view-slot backend "development/code" 10) (let* ((data (lime.x11::%navigation-snapshot backend)) (restored (lime.x11::%navigation-read-data data world))) (is (equal data (list :activities (lime.x11::navigation-state-activities restored) :views (lime.x11::navigation-state-views restored) :resume (lime.x11::navigation-state-resume restored)))) (dolist (bad '((:activities (("development" 1) ("chill" 1)) :views nil :resume nil) (:activities (("development" 0)) :views nil :resume nil) (:activities (("missing" 1)) :views nil :resume nil) (:activities nil :views (("development/code" 1) ("development/code" 2)) :resume nil))) (signals error (lime.x11::%navigation-read-data bad world))) (let ((bad (copy-tree data))) (setf (second (first (getf bad :resume))) "chill") (signals error (lime.x11::%navigation-read-data bad world))) (setf (gethash backend lime.x11::*backend-navigation-states*) restored) (is (= 2 (backend-activity-slot backend "development"))) (is (= 10 (backend-view-slot backend "development/code")))))) (test activity-compaction-preserves-order-without-mutating-input (let* ((existing '(("c" 9) ("a" 1) ("removed" 4))) (before (copy-tree existing)) (result (lime.x11::%navigation-activity-slots existing '("new" "a" "c" "last")))) (is (equal '(("a" 1) ("c" 2) ("new" 3) ("last" 4)) result)) (is (equal before existing)) (setf (second (first result)) 999) (is (equal before existing)) (is (null (lime.x11::%navigation-activity-slots existing nil))))) (test old-sparse-activity-shortcuts-load-in-bar-order-without-changing-view-slots (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) (create-activity world "chill" "Chill") (let* ((data '(:activities (("development" 8) ("chill" 3)) :views (("development/code" 10)) :resume nil)) (before-data (copy-tree data)) (before-world (lime.persistence:snapshot-world world)) (state (lime.x11::%navigation-read-data data world))) (is (equal '(("chill" 1) ("development" 2)) (lime.x11::navigation-state-activities state))) (is (equal before-data data)) (setf (gethash backend lime.x11::*backend-navigation-states*) state) (is (= 2 (backend-activity-slot backend "development"))) (is (= 10 (backend-view-slot backend "development/code"))) (is (equalp before-world (lime.persistence:snapshot-world world))) (create-activity world "new" "Alphabetically first") (is (= 3 (backend-activity-slot backend "new"))) (let ((snapshot (lime.x11::%navigation-snapshot backend))) (is (equal (getf snapshot :activities) (lime.x11::navigation-state-activities (lime.x11::%navigation-read-data snapshot world)))))))) (test activity-deletion-compacts-before-append-even-without-an-intermediate-render (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) (create-activity world "first" "A first") (create-activity world "last" "Z last") (backend-set-view-slot backend "development/code" 9) (let ((state (lime.x11::%navigation-state backend))) (is (equal '(("first" 1) ("development" 2) ("last" 3)) (lime.x11::navigation-state-activities state))) (let ((generation (lime.x11::navigation-state-generation state))) (delete-activity world "first") (create-activity world "new" "A new") (let ((before (lime.persistence:snapshot-world world))) (is (equal '(("development" 1) ("last" 2) ("new" 3)) (getf (backend-navigation-slots backend) :activities))) (is (> (lime.x11::navigation-state-generation state) generation)) (is (= 9 (backend-view-slot backend "development/code"))) (dolist (head-id '("main")) (is (equal '("development" "last" "new") (mapcar (lambda (entry) (getf entry :id)) (lime.x11::%bar-activity-entries backend head-id))))) (is (equalp before (lime.persistence:snapshot-world world)))))))) (test numbered-current-activity-and-view-do-not-reset-dirty-edits (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)) (p (current-presentation world "main"))) (set-presentation-layout-mode world (presentation-id p) :monocle) (let ((before (lime.persistence:snapshot-world world))) (is (eq :close (ui-result-kind (backend-select-activity-slot backend 1)))) (is (eq :close (ui-result-kind (backend-select-view-slot backend 1)))) (is (equalp before (lime.persistence:snapshot-world world))) (is (presentation-dirty-p p))))) (test navigation-session-envelope-migrates-v1-without-inventing-views (let* ((world (make-world)) (activity (create-activity world "scratch" "Scratch")) (legacy (list :format :lime-session :version 1 :world (lime.persistence:snapshot-world world) :server-token (make-string 32 :initial-element #\A) :clients nil :focused-head nil :focus-root nil))) (is (equal (activity-id activity) (activity-id (first (list-activities (lime.x11::%validate-session-envelope legacy)))))) (let ((modern (copy-tree legacy))) (setf (getf modern :version) 2 (getf modern :navigation) '(:activities (("scratch" 1)) :views nil :resume nil)) (is (null (activity-view-ids (find-activity (lime.x11::%validate-session-envelope modern) "scratch")))) (setf (getf modern :navigation) '(:activities (("missing" 1)) :views nil :resume nil)) (signals error (lime.x11::%validate-session-envelope modern))))) (test activity-strip-highlights-the-local-activity-without-view-suffixes (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) (create-activity world "chill" "Chill") (create-head world "right") (setf (gethash "right" (lime.x11::x11-backend-heads backend)) (make-x11-head :head-id "right" :x 840 :y 30 :width 800 :height 600) (lime.x11::x11-backend-head-ids backend) '("main" "right")) (open-activity-draft world "right" "chill") (backend-set-activity-slot backend "development" 1) (let* ((before (lime.persistence:snapshot-world world)) (left (lime.x11::%bar-activity-entries backend "main")) (right (lime.x11::%bar-activity-entries backend "right"))) (is (equal '("Development" "Chill") (mapcar (lambda (e) (getf e :text)) left))) (is (equal '("Development" "Chill") (mapcar (lambda (e) (getf e :text)) right))) (is (getf (first left) :active-p)) (is (getf (second right) :active-p)) (is (equalp before (lime.persistence:snapshot-world world)))) (open-activity-draft world "right" "development") (is (equal "Development" (getf (first (lime.x11::%bar-activity-entries backend "right")) :text))) (is (equal "Development" (getf (first (lime.x11::%bar-activity-entries backend "main")) :text))))) (defun choose-view-update (result id) (funcall (ui-candidate-action (find id (ui-result-candidates result) :key #'ui-candidate-id :test #'equal)))) (test checkpoint-update-picker-is-local-explicit-and-nondestructive-until-confirmed (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)) (p (current-presentation world "main"))) (create-view world "development/docs" "development" "Docs" nil) (create-activity world "chill" "Chill") (create-view world "chill/code" "chill" "Code" nil) ;; The source label is not required, and must not silently pick the target. (setf (presentation-source-view-id p) nil) (set-presentation-layout-mode world (presentation-id p) :monocle) (let* ((before (lime.persistence:snapshot-world world)) (picker (lime.x11::%ui-view-update-picker-result backend)) (confirmation (choose-view-update picker '(:update-view "development/docs")))) (is (equal '((:update-view "development/code") (:update-view "development/docs")) (mapcar #'ui-candidate-id (ui-result-candidates picker)))) (is (lime.x11::%ui-update-current-view-candidate backend)) (is (eq :cancel (ui-candidate-id (first (ui-result-candidates confirmation))))) (is (search "Docs" (lime.ui:ui-result-message confirmation))) (is (eq :close (ui-result-kind (choose-view-update confirmation :cancel)))) (is (equalp before (lime.persistence:snapshot-world world))) (is (eq :close (ui-result-kind (choose-view-update confirmation '(:confirm-update-view "development/docs"))))) (is (eq :monocle (view-layout-mode (find-view world "development/docs")))) (is (equal (presentation-client-ids p) (mapcar #'placement-client-id (view-placements (find-view world "development/docs")))))) (is (eq :manual (view-layout-mode (find-view world "development/code")))) (is (null (view-placements (find-view world "chill/code")))) (is (eq p (current-presentation world "main"))) (is (null (presentation-source-view-id p))) (is (validate-world world)))) (test checkpoint-update-rejects-changed-arrangements-and-heads (dolist (change '(:model :head)) (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)) (picker (lime.x11::%ui-view-update-picker-result backend)) (confirmation (choose-view-update picker '(:update-view "development/code")))) (ecase change (:model (set-presentation-layout-mode world (presentation-id (current-presentation world "main")) :monocle)) (:head (setf (lime.x11::x11-backend-focused-head-id backend) "other"))) (let ((before (lime.persistence:snapshot-world world))) (is (eq :keep-open (ui-result-kind (choose-view-update picker '(:update-view "development/code"))))) (is (eq :keep-open (ui-result-kind (choose-view-update confirmation '(:confirm-update-view "development/code"))))) (is (equalp before (lime.persistence:snapshot-world world))))))) (test checkpoint-update-picker-explains-an-empty-library (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) (create-activity world "empty" "Empty") (open-activity-draft world "main" "empty") (let* ((before (lime.persistence:snapshot-world world)) (result (lime.x11::%ui-view-update-picker-result backend))) (is (null (ui-result-candidates result))) (is (search "Save a new checkpoint first" (lime.ui:ui-result-message result))) (is (null (lime.x11::%ui-update-current-view-candidate backend))) (is (equalp before (lime.persistence:snapshot-world world)))))) (test activity-strip-fitting-is-bounded-ordered-and-keeps-the-active-tab (let* ((entries (list (list :id "one" :text "1 One") (list :id "two" :text "2 Two") (list :id "three" :text "3 Three") (list :id "four" :text "4 Four:Draft*" :active-p t) (list :id "five" :text "5 Five"))) (before (copy-tree entries)) (measure (lambda (text) (* 5 (length text))))) (loop for width from 0 to 360 by 9 do (multiple-value-bind (text prefix used runs) (lime.x11::%fit-bar-activities entries width measure #'lime.x11::%bar-short-text) (declare (ignore text prefix)) (is (<= 0 used width)) (is (loop for run in runs always (<= 0 (getf run :x) (+ (getf run :x) (getf run :width)) width))) (is (loop for (a b) on runs while b always (< (+ (getf a :x) (getf a :width)) (getf b :x)))) (when (>= width 45) (is (find "four" runs :key (lambda (r) (getf (getf r :entry) :id)) :test #'equal))) (when (>= width 300) (is (= 5 (length runs))) (is (notany (lambda (r) (getf r :overflow-p)) runs))))) (is (equal entries before)) (let* ((fit (lambda (ignored budget ignored-measure) (declare (ignore ignored ignored-measure)) (lime.x11::%fit-bar-activities entries budget measure #'lime.x11::%bar-short-text))) (layout (lime.x11::%bar-text-layout 420 "" "[]=" "Some window" (make-string 100 :initial-element #\s) measure :label-fit fit :minimum-label-width 96))) (is (getf layout :label-runs)) (is (find-if (lambda (r) (getf r :overflow-p)) (getf layout :label-runs))) (is (<= (getf layout :label-x) (getf layout :layout-x) (getf layout :title-left) (getf layout :title-right) (getf layout :status-x))))))