Refactor tp layer API to new specification, remove old API
Co-authored-by: Kinneyzhang <38454496+Kinneyzhang@users.noreply.github.com>
This commit is contained in:
copilot-swe-agent[bot]
parent
dbd790d0fd
commit
808fa94214
341
tp-tests.el
341
tp-tests.el
@ -151,26 +151,26 @@
|
||||
;;; Layer Definition Tests
|
||||
;;; ============================================================
|
||||
|
||||
(ert-deftest tp-test-layer-define ()
|
||||
"Test tp-layer-define creates a layer."
|
||||
(ert-deftest tp-test-define-layer ()
|
||||
"Test tp-define-layer creates a layer."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-layer-define test-layer '(face bold help-echo "test"))
|
||||
(tp-define-layer test-layer (face bold help-echo "test"))
|
||||
(should (assoc 'test-layer tp-layer-alist))
|
||||
(should (equal (cdr (assoc 'test-layer tp-layer-alist))
|
||||
'(face bold help-echo "test")))))
|
||||
|
||||
(ert-deftest tp-test-layer-define-updates-existing ()
|
||||
"Test tp-layer-define updates existing layer."
|
||||
(ert-deftest tp-test-define-layer-updates-existing ()
|
||||
"Test tp-define-layer updates existing layer."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-layer-define test-layer '(face bold))
|
||||
(tp-layer-define test-layer '(face italic))
|
||||
(tp-define-layer test-layer (face bold))
|
||||
(tp-define-layer test-layer (face italic))
|
||||
(should (equal (cdr (assoc 'test-layer tp-layer-alist))
|
||||
'(face italic)))))
|
||||
|
||||
(ert-deftest tp-test-layer-props ()
|
||||
"Test tp-layer-props returns properties with tp-name."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-layer-define my-layer '(face bold))
|
||||
(tp-define-layer my-layer (face bold))
|
||||
(let ((props (tp-layer-props 'my-layer)))
|
||||
(should (eq (plist-get props 'face) 'bold))
|
||||
(should (eq (plist-get props 'tp-name) 'my-layer)))))
|
||||
@ -183,50 +183,47 @@
|
||||
(ert-deftest tp-test-layer-undefine ()
|
||||
"Test tp-layer-undefine removes layer definition."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-layer-define test-layer '(face bold))
|
||||
(tp-define-layer test-layer (face bold))
|
||||
(should (assoc 'test-layer tp-layer-alist))
|
||||
(tp-layer-undefine 'test-layer)
|
||||
(should-not (assoc 'test-layer tp-layer-alist))))
|
||||
|
||||
;;; ============================================================
|
||||
;;; Layer Group Tests
|
||||
;;; Layer Group Tests (using tp-define-layer with multiple layers)
|
||||
;;; ============================================================
|
||||
|
||||
(ert-deftest tp-test-group-define ()
|
||||
"Test tp-group-define creates a layer group."
|
||||
(ert-deftest tp-test-define-layer-multiple ()
|
||||
"Test tp-define-layer creates a layer group with multiple layers."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-group-define my-group
|
||||
layer1 '(face bold)
|
||||
layer2 '(face italic)
|
||||
layer3 '(face underline))
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer my-group
|
||||
layer1
|
||||
(face italic)
|
||||
(face underline))
|
||||
(should (assoc 'my-group tp-layer-groups))
|
||||
(should (assoc 'layer1 tp-layer-alist))
|
||||
(should (assoc 'layer2 tp-layer-alist))
|
||||
(should (assoc 'layer3 tp-layer-alist))
|
||||
;; Check all layers are present in the group
|
||||
(let ((layers (cdr (assoc 'my-group tp-layer-groups))))
|
||||
(should (= (length layers) 3))
|
||||
(should (memq 'layer1 layers))
|
||||
(should (memq 'layer2 layers))
|
||||
(should (memq 'layer3 layers)))))
|
||||
(should (memq 'layer1 layers)))))
|
||||
|
||||
(ert-deftest tp-test-group-props ()
|
||||
"Test tp-group-props returns all layer properties."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-group-define my-group
|
||||
layer1 '(face bold)
|
||||
layer2 '(face italic))
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer my-group layer1 layer2)
|
||||
(let ((props-list (tp-group-props 'my-group)))
|
||||
(should (= (length props-list) 2))
|
||||
;; Check that both layers are present (order may vary)
|
||||
;; Check that both layers are present
|
||||
(let ((faces (mapcar (lambda (p) (plist-get p 'face)) props-list)))
|
||||
(should (or (memq 'bold faces) (memq 'italic faces)))))))
|
||||
(should (memq 'bold faces))
|
||||
(should (memq 'italic faces))))))
|
||||
|
||||
(ert-deftest tp-test-group-undefine ()
|
||||
"Test tp-group-undefine removes group definition."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-group-define my-group
|
||||
layer1 '(face bold))
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer my-group layer1)
|
||||
(should (assoc 'my-group tp-layer-groups))
|
||||
(tp-group-undefine 'my-group)
|
||||
(should-not (assoc 'my-group tp-layer-groups))))
|
||||
@ -234,8 +231,9 @@
|
||||
(ert-deftest tp-test-layer-reset ()
|
||||
"Test tp-layer-reset clears all definitions."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-group-define group1 layer2 '(face italic))
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer group1 layer1 layer2)
|
||||
(should tp-layer-alist)
|
||||
(should tp-layer-groups)
|
||||
(tp-layer-reset)
|
||||
@ -243,144 +241,186 @@
|
||||
(should-not tp-layer-groups)))
|
||||
|
||||
;;; ============================================================
|
||||
;;; Layer Stack Operations Tests
|
||||
;;; Layer Stack Operations Tests (New API)
|
||||
;;; ============================================================
|
||||
|
||||
(ert-deftest tp-test-layer-push ()
|
||||
"Test tp-layer-push adds layer to stack."
|
||||
(ert-deftest tp-test-push-layer ()
|
||||
"Test tp-push-layer adds layer to stack."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(should (eq (tp-get 1 'face) 'bold))
|
||||
(should (eq (tp-get 1 'tp-name) 'layer1))))
|
||||
|
||||
(ert-deftest tp-test-layer-push-multiple ()
|
||||
(ert-deftest tp-test-push-layer-multiple ()
|
||||
"Test pushing multiple layers."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
;; layer2 should be on top (visible)
|
||||
(should (eq (tp-get 1 'face) 'italic))
|
||||
(should (eq (tp-get 1 'tp-name) 'layer2))
|
||||
;; layer1 should be in the stack below
|
||||
(should (tp-get 1 'tp-layers))))
|
||||
|
||||
(ert-deftest tp-test-layer-push-error-on-duplicate ()
|
||||
"Test tp-layer-push errors on duplicate layer."
|
||||
(ert-deftest tp-test-delete-layer ()
|
||||
"Test tp-delete-layer removes layer from stack."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(should-error (tp-layer-push 1 6 'layer1))))
|
||||
|
||||
(ert-deftest tp-test-layer-delete ()
|
||||
"Test tp-layer-delete removes layer from stack."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
;; Delete top layer
|
||||
(tp-layer-delete 1 6 'layer2)
|
||||
(tp-delete-layer 1 6 'layer2)
|
||||
;; layer1 should now be visible
|
||||
(should (eq (tp-get 1 'face) 'bold))
|
||||
(should (eq (tp-get 1 'tp-name) 'layer1))))
|
||||
|
||||
(ert-deftest tp-test-layer-delete-from-middle ()
|
||||
(ert-deftest tp-test-delete-layer-from-middle ()
|
||||
"Test deleting layer from middle of stack."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-define layer3 '(face underline))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-layer-push 1 6 'layer3)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer layer3 (face underline))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
(tp-push-layer 1 6 'layer3)
|
||||
;; Delete middle layer
|
||||
(tp-layer-delete 1 6 'layer2)
|
||||
(tp-delete-layer 1 6 'layer2)
|
||||
;; Top layer should still be visible
|
||||
(should (eq (tp-get 1 'tp-name) 'layer3))
|
||||
;; layer2 should not exist anymore
|
||||
(should-not (tp-layer-exists-p 1 6 'layer2))))
|
||||
|
||||
(ert-deftest tp-test-layer-rotate ()
|
||||
"Test tp-layer-rotate cycles layers."
|
||||
(ert-deftest tp-test-pop-layer ()
|
||||
"Test tp-pop-layer removes top layer."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-define layer3 '(face underline))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-layer-push 1 6 'layer3)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
;; Pop top layer
|
||||
(tp-pop-layer 1 6)
|
||||
;; layer1 should now be visible
|
||||
(should (eq (tp-get 1 'tp-name) 'layer1))))
|
||||
|
||||
(ert-deftest tp-test-rotate-layer ()
|
||||
"Test tp-rotate-layer cycles layers."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer layer3 (face underline))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
(tp-push-layer 1 6 'layer3)
|
||||
;; layer3 is on top
|
||||
(should (eq (tp-layer-top 1 6) 'layer3))
|
||||
;; Rotate once - layer2 should be on top
|
||||
(tp-layer-rotate 1 6)
|
||||
(tp-rotate-layer 1 6)
|
||||
(should (eq (tp-layer-top 1 6) 'layer2))
|
||||
;; Rotate again - layer1 should be on top
|
||||
(tp-layer-rotate 1 6)
|
||||
(tp-rotate-layer 1 6)
|
||||
(should (eq (tp-layer-top 1 6) 'layer1))
|
||||
;; Rotate again - layer3 should be on top (cycled back)
|
||||
(tp-layer-rotate 1 6)
|
||||
(tp-rotate-layer 1 6)
|
||||
(should (eq (tp-layer-top 1 6) 'layer3))))
|
||||
|
||||
(ert-deftest tp-test-layer-pin ()
|
||||
"Test tp-layer-pin brings layer to top."
|
||||
(ert-deftest tp-test-pin-layer ()
|
||||
"Test tp-pin-layer brings layer to top."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-define layer3 '(face underline))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-layer-push 1 6 'layer3)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer layer3 (face underline))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
(tp-push-layer 1 6 'layer3)
|
||||
;; Pin layer1 to top
|
||||
(tp-layer-pin 1 6 'layer1)
|
||||
(tp-pin-layer 1 6 'layer1)
|
||||
(should (eq (tp-layer-top 1 6) 'layer1))))
|
||||
|
||||
(ert-deftest tp-test-layer-pin-error-on-nonexistent ()
|
||||
"Test tp-layer-pin errors on nonexistent layer."
|
||||
(ert-deftest tp-test-raise-layer ()
|
||||
"Test tp-raise-layer moves layer up."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(should-error (tp-layer-pin 1 6 'nonexistent))))
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer layer3 (face underline))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
(tp-push-layer 1 6 'layer3)
|
||||
;; layer3 is at idx 0, layer2 at 1, layer1 at 2
|
||||
;; Raise layer1 by 2 (move to top)
|
||||
(tp-raise-layer 1 6 'layer1 2)
|
||||
(should (eq (tp-layer-top 1 6) 'layer1))))
|
||||
|
||||
(ert-deftest tp-test-layer-hide ()
|
||||
"Test tp-layer-hide moves layer to bottom."
|
||||
(ert-deftest tp-test-switch-layer ()
|
||||
"Test tp-switch-layer swaps two layers."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
;; layer2 is on top
|
||||
(should (eq (tp-layer-top 1 6) 'layer2))
|
||||
;; Hide layer2
|
||||
(tp-layer-hide 1 6 'layer2)
|
||||
;; Switch layer1 and layer2
|
||||
(tp-switch-layer 1 6 'layer1 'layer2)
|
||||
;; layer1 should now be on top
|
||||
(should (eq (tp-layer-top 1 6) 'layer1))))
|
||||
|
||||
(ert-deftest tp-test-layer-show ()
|
||||
"Test tp-layer-show brings layer to top."
|
||||
(ert-deftest tp-test-put-layer-at-idx ()
|
||||
"Test tp-put-layer inserts layer at specified index."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
;; Hide layer2
|
||||
(tp-layer-hide 1 6 'layer2)
|
||||
(should (eq (tp-layer-top 1 6) 'layer1))
|
||||
;; Show layer2 again
|
||||
(tp-layer-show 1 6 'layer2)
|
||||
(should (eq (tp-layer-top 1 6) 'layer2))))
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer layer3 (face underline))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
;; Insert layer3 at index 1 (between layer2 and layer1)
|
||||
(tp-put-layer 1 6 'layer3 1)
|
||||
;; layer2 should still be on top
|
||||
(should (eq (tp-layer-top 1 6) 'layer2))
|
||||
;; Should have 3 layers
|
||||
(should (= (tp-layer-count 1 6) 3))))
|
||||
|
||||
(ert-deftest tp-test-merge-layers ()
|
||||
"Test tp-merge-layers merges specified layers."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (help-echo "test"))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
;; Merge layer1 and layer2 into merged-layer
|
||||
(tp-merge-layers 1 6 'merged-layer '(layer1 layer2))
|
||||
;; Should have 1 layer now
|
||||
(should (= (tp-layer-count 1 6) 1))
|
||||
;; The merged layer should have properties from both
|
||||
(should (eq (tp-get 1 'tp-name) 'merged-layer))))
|
||||
|
||||
(ert-deftest tp-test-flatten-layers ()
|
||||
"Test tp-flatten-layers flattens all layers."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (help-echo "test"))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
;; Flatten all layers into flat-layer
|
||||
(tp-flatten-layers 1 6 'flat-layer)
|
||||
;; Should have 1 layer now
|
||||
(should (= (tp-layer-count 1 6) 1))
|
||||
(should (eq (tp-get 1 'tp-name) 'flat-layer))))
|
||||
|
||||
;;; ============================================================
|
||||
;;; Layer Query Tests
|
||||
@ -390,12 +430,12 @@
|
||||
"Test tp-layer-list returns all layer names."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-define layer3 '(face underline))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-layer-push 1 6 'layer3)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-define-layer layer3 (face underline))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
(tp-push-layer 1 6 'layer3)
|
||||
(let ((layers (tp-layer-list 1 6)))
|
||||
(should (= (length layers) 3))
|
||||
(should (memq 'layer1 layers))
|
||||
@ -406,19 +446,19 @@
|
||||
"Test tp-layer-count returns correct count."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(should (= (tp-layer-count 1 6) 1))
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
(should (= (tp-layer-count 1 6) 2))))
|
||||
|
||||
(ert-deftest tp-test-layer-exists-p ()
|
||||
"Test tp-layer-exists-p correctly detects layers."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(should (tp-layer-exists-p 1 6 'layer1))
|
||||
(should-not (tp-layer-exists-p 1 6 'layer2))))
|
||||
|
||||
@ -426,11 +466,11 @@
|
||||
"Test tp-layer-top returns top layer name."
|
||||
(tp-test-with-temp-buffer
|
||||
(insert "Hello")
|
||||
(tp-layer-define layer1 '(face bold))
|
||||
(tp-layer-define layer2 '(face italic))
|
||||
(tp-layer-push 1 6 'layer1)
|
||||
(tp-define-layer layer1 (face bold))
|
||||
(tp-define-layer layer2 (face italic))
|
||||
(tp-push-layer 1 6 'layer1)
|
||||
(should (eq (tp-layer-top 1 6) 'layer1))
|
||||
(tp-layer-push 1 6 'layer2)
|
||||
(tp-push-layer 1 6 'layer2)
|
||||
(should (eq (tp-layer-top 1 6) 'layer2))))
|
||||
|
||||
;;; ============================================================
|
||||
@ -448,33 +488,12 @@
|
||||
(should (eq (get-text-property 0 'face str) 'bold))
|
||||
(should (equal (get-text-property 0 'help-echo str) "test"))))
|
||||
|
||||
(ert-deftest tp-test-layer-propertize ()
|
||||
"Test tp-layer-propertize applies layer to string."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-layer-define my-layer '(face bold help-echo "greeting"))
|
||||
(let ((str (tp-layer-propertize "Hello" 'my-layer)))
|
||||
(should (eq (get-text-property 0 'face str) 'bold))
|
||||
(should (equal (get-text-property 0 'help-echo str) "greeting")))))
|
||||
|
||||
(ert-deftest tp-test-layer-propertize-error-on-undefined ()
|
||||
"Test tp-layer-propertize errors on undefined layer."
|
||||
(tp-test-with-temp-buffer
|
||||
(should-error (tp-layer-propertize "Hello" 'undefined-layer))))
|
||||
|
||||
(ert-deftest tp-test-group-propertize ()
|
||||
"Test tp-group-propertize applies group to string."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-group-define my-group
|
||||
layer1 '(face bold)
|
||||
layer2 '(help-echo "test"))
|
||||
(let ((str (tp-group-propertize "Hello" 'my-group)))
|
||||
(should (stringp str))
|
||||
(should (= (length str) 5)))))
|
||||
|
||||
(ert-deftest tp-test-group-propertize-error-on-undefined ()
|
||||
"Test tp-group-propertize errors on undefined group."
|
||||
(tp-test-with-temp-buffer
|
||||
(should-error (tp-group-propertize "Hello" 'undefined-group))))
|
||||
(ert-deftest tp-test-propertize-with-region ()
|
||||
"Test tp-propertize with object and region."
|
||||
(let* ((str (copy-sequence "Hello World"))
|
||||
(result (tp-propertize str 0 5 'face 'bold)))
|
||||
(should (stringp result))
|
||||
(should (eq (get-text-property 0 'face result) 'bold))))
|
||||
|
||||
;;; ============================================================
|
||||
;;; Match and Regexp Tests
|
||||
@ -644,9 +663,7 @@
|
||||
"Test that all aliases are properly defined."
|
||||
(should (fboundp 'tp-set))
|
||||
(should (fboundp 'tp-layer-properties))
|
||||
(should (fboundp 'tp-layer-group-define))
|
||||
(should (fboundp 'tp-layer-group-properties))
|
||||
(should (fboundp 'tp-layer-group-propertize))
|
||||
(should (fboundp 'tp-layer-group-undefine)))
|
||||
|
||||
(ert-deftest tp-test-aliases-work ()
|
||||
@ -738,22 +755,6 @@
|
||||
(should (eq (get-text-property 12 'face result) 'bold))
|
||||
(should (null (get-text-property 0 'face result)))))
|
||||
|
||||
(ert-deftest tp-test-propertize-with-region ()
|
||||
"Test tp-propertize with object and region."
|
||||
(let* ((str (copy-sequence "Hello World"))
|
||||
(result (tp-propertize str 0 5 'face 'bold)))
|
||||
(should (stringp result))
|
||||
(should (eq (get-text-property 0 'face result) 'bold))))
|
||||
|
||||
(ert-deftest tp-test-layer-propertize-with-range ()
|
||||
"Test tp-layer-propertize with start/end range."
|
||||
(tp-test-with-temp-buffer
|
||||
(tp-layer-define range-layer '(face bold))
|
||||
(let* ((str (copy-sequence "Hello World"))
|
||||
(result (tp-layer-propertize str 'range-layer 0 5)))
|
||||
(should (stringp result))
|
||||
(should (eq (get-text-property 0 'face result) 'bold)))))
|
||||
|
||||
;;; ============================================================
|
||||
;;; Enhanced tp-get Tests
|
||||
;;; ============================================================
|
||||
|
||||
886
tp.el
886
tp.el
@ -111,43 +111,6 @@ The first layer in the definition is the top layer."
|
||||
(push (cons ',name ',layer-names) tp-layer-groups))
|
||||
(assoc ',name tp-layer-groups))))))
|
||||
|
||||
;;; Legacy aliases for backward compatibility
|
||||
(defmacro tp-layer-define (name properties)
|
||||
"Define a text property layer named NAME with PROPERTIES.
|
||||
DEPRECATED: Use `tp-define-layer' instead.
|
||||
The layer is stored in `tp-layer-alist'.
|
||||
PROPERTIES should be a plist of text properties."
|
||||
(declare (indent defun))
|
||||
`(progn
|
||||
(if (assoc ',name tp-layer-alist)
|
||||
(setf (cdr (assoc ',name tp-layer-alist)) ,properties)
|
||||
(push (cons ',name ,properties) tp-layer-alist))
|
||||
(assoc ',name tp-layer-alist)))
|
||||
|
||||
(defmacro tp-group-define (name &rest layers)
|
||||
"Define a layer group named NAME containing LAYERS.
|
||||
DEPRECATED: Use `tp-define-layer' instead.
|
||||
LAYERS are specified as alternating NAME PROPERTIES pairs."
|
||||
(declare (indent defun))
|
||||
`(let ((layer-names
|
||||
(nreverse
|
||||
(-map (lambda (lst)
|
||||
(let* ((layer-name (car lst))
|
||||
;; Evaluate the quoted plist to get the actual plist
|
||||
(props (eval (cadr lst))))
|
||||
(if (assoc layer-name tp-layer-alist)
|
||||
(setf (cdr (assoc layer-name tp-layer-alist)) props)
|
||||
(push (cons layer-name props) tp-layer-alist))
|
||||
layer-name))
|
||||
(-partition 2 ',layers)))))
|
||||
(if (assoc ',name tp-layer-groups)
|
||||
(setf (cdr (assoc ',name tp-layer-groups)) layer-names)
|
||||
(push (cons ',name layer-names) tp-layer-groups))
|
||||
(assoc ',name tp-layer-groups)))
|
||||
|
||||
(defalias 'tp-layer-group-define 'tp-group-define
|
||||
"Alias for `tp-group-define'.")
|
||||
|
||||
(defun tp-layer-props (layer-name)
|
||||
"Return properties for layer LAYER-NAME from `tp-layer-alist'.
|
||||
Appends 'tp-name property to identify the layer."
|
||||
@ -989,117 +952,559 @@ Returns a list of (START END PROPERTIES) for matching intervals."
|
||||
(list (+ start i-start) (+ start i-end) props)))
|
||||
start end object))
|
||||
|
||||
(defun tp-layer-set (start end name &optional object)
|
||||
"Set NAME as the layer name for text from START to END in OBJECT.
|
||||
This names the current visible layer without adding new properties.
|
||||
OBJECT defaults to current buffer."
|
||||
(if (tp-empty-p (or object (current-buffer)))
|
||||
(add-text-properties start end (list 'tp-name name) object)
|
||||
;;; New Layer API Functions
|
||||
|
||||
(defun tp--normalize-layer-spec (layer-spec)
|
||||
"Normalize LAYER-SPEC to a plist with tp-name.
|
||||
LAYER-SPEC can be:
|
||||
- A symbol (layer name from tp-layer-alist)
|
||||
- A plist (inline layer definition)
|
||||
- A list (name &rest plist) for named inline layer."
|
||||
(cond
|
||||
;; Symbol - look up in tp-layer-alist
|
||||
((symbolp layer-spec)
|
||||
(or (tp-layer-props layer-spec)
|
||||
(error "Layer %S not found in tp-layer-alist" layer-spec)))
|
||||
;; List starting with symbol followed by plist - named inline layer (name &rest plist)
|
||||
((and (listp layer-spec)
|
||||
(symbolp (car layer-spec))
|
||||
(not (keywordp (car layer-spec)))
|
||||
(cdr layer-spec))
|
||||
(let ((name (car layer-spec))
|
||||
(props (cdr layer-spec)))
|
||||
(append props (list 'tp-name name))))
|
||||
;; Plist (starts with keyword or property name)
|
||||
((and (listp layer-spec) layer-spec)
|
||||
layer-spec)
|
||||
(t (error "Invalid layer spec: %S" layer-spec))))
|
||||
|
||||
(defun tp--get-layer-stack (pos object)
|
||||
"Get the layer stack at POS in OBJECT as a list.
|
||||
Returns (TOP-PROPS . BELOW-PROPS-LIST)."
|
||||
(let* ((props (text-properties-at pos object))
|
||||
(tp-layers-idx (-elem-index 'tp-layers props))
|
||||
(top-props (if tp-layers-idx
|
||||
(-remove-at-indices (list tp-layers-idx (1+ tp-layers-idx)) props)
|
||||
props))
|
||||
(below-props (plist-get props 'tp-layers)))
|
||||
(cons top-props below-props)))
|
||||
|
||||
(defun tp--build-layer-props (layer-list)
|
||||
"Build text properties from LAYER-LIST.
|
||||
First element is top layer, rest are in tp-layers."
|
||||
(if (null layer-list)
|
||||
nil
|
||||
(append (car layer-list)
|
||||
(list 'tp-layers (cdr layer-list)))))
|
||||
|
||||
(defun tp--layer-stack-to-list (top belows)
|
||||
"Convert TOP and BELOWS to a flat list of layers."
|
||||
(if top
|
||||
(cons top belows)
|
||||
belows))
|
||||
|
||||
(defun tp--get-layer-by-idx-or-name (layers idx-or-name)
|
||||
"Find layer in LAYERS by IDX-OR-NAME.
|
||||
Returns (index . layer-props) or nil."
|
||||
(cond
|
||||
((integerp idx-or-name)
|
||||
(let ((actual-idx (if (< idx-or-name 0)
|
||||
(+ (length layers) idx-or-name)
|
||||
idx-or-name)))
|
||||
(when (and (>= actual-idx 0) (< actual-idx (length layers)))
|
||||
(cons actual-idx (nth actual-idx layers)))))
|
||||
((symbolp idx-or-name)
|
||||
(cl-loop for layer in layers
|
||||
for i from 0
|
||||
when (equal idx-or-name (plist-get layer 'tp-name))
|
||||
return (cons i layer)))
|
||||
(t nil)))
|
||||
|
||||
(defun tp--parse-layer-args (args)
|
||||
"Parse flexible layer function arguments.
|
||||
Returns (START END LAYER-SPEC IDX OBJECT) for buffer/string range,
|
||||
or (STRING LAYER-SPEC IDX nil nil) for entire string."
|
||||
(cond
|
||||
;; First arg is a string - apply to entire string
|
||||
;; (tp-put-layer string layer idx)
|
||||
((stringp (car args))
|
||||
(list (car args) (cadr args) (caddr args) nil nil))
|
||||
;; First arg is a number - buffer/string region
|
||||
;; (tp-put-layer start end layer idx object)
|
||||
((numberp (car args))
|
||||
(list (car args) (cadr args) (caddr args) (cadddr args) (nth 4 args)))
|
||||
(t (error "Invalid arguments: %S" args))))
|
||||
|
||||
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object)
|
||||
"Set layer(s) at a specific index position.
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-put-layer START END LAYER IDX OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-put-layer STRING LAYER IDX)
|
||||
|
||||
LAYER can be:
|
||||
- A symbol (layer name from tp-layer-alist or tp-layer-groups)
|
||||
- A plist (inline layer definition)
|
||||
- A list (NAME &rest PLIST) for named inline layer
|
||||
- A list of the above for multiple layers
|
||||
|
||||
IDX specifies where to insert:
|
||||
- 0 means top (visible layer)
|
||||
- -1 means bottom
|
||||
- Other values insert at that position
|
||||
|
||||
OBJECT defaults to current buffer for region form."
|
||||
(let (start end layer-spec idx obj)
|
||||
(cond
|
||||
;; Entire string form: (tp-put-layer string layer idx)
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)
|
||||
layer-spec end-or-layer
|
||||
idx (or layer-or-idx 0)))
|
||||
;; Region form: (tp-put-layer start end layer idx object)
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-layer
|
||||
layer-spec layer-or-idx
|
||||
idx (or idx-or-object 0)
|
||||
obj object)))
|
||||
|
||||
;; Normalize layer-spec to a list of layer property lists
|
||||
(let ((layers-to-add
|
||||
(cond
|
||||
;; Check if it's a group name
|
||||
((and (symbolp layer-spec)
|
||||
(assoc layer-spec tp-layer-groups))
|
||||
(tp-group-props layer-spec))
|
||||
;; Single layer spec
|
||||
((or (symbolp layer-spec)
|
||||
(and (listp layer-spec)
|
||||
(or (keywordp (car layer-spec))
|
||||
(and (symbolp (car layer-spec))
|
||||
(cdr layer-spec)
|
||||
(not (listp (cadr layer-spec)))))))
|
||||
(list (tp--normalize-layer-spec layer-spec)))
|
||||
;; List of layer specs (multiple layers)
|
||||
((and (listp layer-spec)
|
||||
(listp (car layer-spec)))
|
||||
(mapcar #'tp--normalize-layer-spec layer-spec))
|
||||
(t (list (tp--normalize-layer-spec layer-spec))))))
|
||||
|
||||
;; Apply layers at specified index
|
||||
(if (tp-empty-p (or obj (current-buffer)))
|
||||
;; No existing properties
|
||||
(set-text-properties start end
|
||||
(tp--build-layer-props layers-to-add)
|
||||
obj)
|
||||
;; Has existing properties
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
||||
(actual-idx (cond
|
||||
((= idx 0) 0)
|
||||
((< idx 0) (max 0 (+ (length current-stack) 1 idx)))
|
||||
(t (min idx (length current-stack)))))
|
||||
;; Insert new layers at the specified position
|
||||
(new-stack (append (seq-take current-stack actual-idx)
|
||||
layers-to-add
|
||||
(seq-drop current-stack actual-idx))))
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(tp--build-layer-props new-stack)
|
||||
obj)))
|
||||
start end obj)))
|
||||
(or obj (cons start end))))
|
||||
|
||||
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object)
|
||||
"Push layer(s) to the top of the layer stack.
|
||||
|
||||
This is equivalent to (tp-put-layer ... LAYER 0 ...).
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-push-layer START END LAYER OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-push-layer STRING LAYER)"
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(tp-put-layer start-or-string end-or-layer 0))
|
||||
((numberp start-or-string)
|
||||
(tp-put-layer start-or-string end-or-layer layer-or-object 0 object))))
|
||||
|
||||
(defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object)
|
||||
"Delete layer by name or index.
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-delete-layer START END LAYER-NAME/IDX OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-delete-layer STRING LAYER-NAME/IDX)
|
||||
|
||||
LAYER-NAME/IDX can be:
|
||||
- A symbol (layer name)
|
||||
- An integer (layer index, 0=top, -1=bottom)"
|
||||
(let (start end layer-id obj)
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)
|
||||
layer-id end-or-idx))
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-idx
|
||||
layer-id idx-or-object
|
||||
obj object)))
|
||||
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(append (plist-put top 'tp-name name)
|
||||
(list 'tp-layers belows))
|
||||
object))
|
||||
start end object))
|
||||
object)
|
||||
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
||||
(found (tp--get-layer-by-idx-or-name current-stack layer-id)))
|
||||
(when found
|
||||
(let ((new-stack (-remove-at (car found) current-stack)))
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(tp--build-layer-props new-stack)
|
||||
obj)))))
|
||||
start end obj)
|
||||
nil))
|
||||
|
||||
;;;###autoload
|
||||
(defun tp-layer-push (start end name &optional object)
|
||||
"Push layer NAME to top of the layer stack from START to END.
|
||||
Uses properties from `tp-layer-alist' if NAME is defined there.
|
||||
OBJECT defaults to current buffer.
|
||||
Signals an error if layer NAME already exists in the region."
|
||||
(declare (indent defun))
|
||||
(when (tp-region-layer-props start end name object)
|
||||
(error "Already exist layer named %S" name))
|
||||
(let ((props (tp-layer-props name)))
|
||||
(if (tp-empty-p (or object (current-buffer)))
|
||||
;; No existing properties, just set the layer properties
|
||||
(set-text-properties start end
|
||||
(append props (list 'tp-layers nil))
|
||||
object)
|
||||
;; Has existing properties, push to layer stack
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(append props
|
||||
(list 'tp-layers (append (list top) belows)))
|
||||
object))
|
||||
start end object)))
|
||||
object)
|
||||
(defun tp-pop-layer (start-or-string &optional end-or-object object)
|
||||
"Pop the top layer from the layer stack.
|
||||
|
||||
(defun tp-layer-delete (start end name &optional object)
|
||||
"Delete layer NAME from the layer stack between START and END.
|
||||
If NAME is the top layer, the next layer becomes visible.
|
||||
This is equivalent to (tp-delete-layer ... 0 ...).
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-pop-layer START END OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-pop-layer STRING)"
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(tp-delete-layer start-or-string 0))
|
||||
((numberp start-or-string)
|
||||
(tp-delete-layer start-or-string end-or-object 0 object))))
|
||||
|
||||
(defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
|
||||
"Raise a layer by N positions in the stack.
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-raise-layer START END IDX/LAYER-NAME N OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-raise-layer STRING IDX/LAYER-NAME N)
|
||||
|
||||
Positive N moves the layer up (toward top/visible).
|
||||
Negative N moves the layer down (toward bottom)."
|
||||
(let (start end layer-id n obj)
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)
|
||||
layer-id end-or-idx
|
||||
n (or idx-or-n 1)))
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-idx
|
||||
layer-id idx-or-n
|
||||
n (or n-or-object 1)
|
||||
obj object)))
|
||||
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
||||
(found (tp--get-layer-by-idx-or-name current-stack layer-id)))
|
||||
(when found
|
||||
(let* ((old-idx (car found))
|
||||
(layer-props (cdr found))
|
||||
(new-idx (max 0 (min (- (length current-stack) 1)
|
||||
(- old-idx n))))
|
||||
(stack-without (-remove-at old-idx current-stack))
|
||||
(new-stack (append (seq-take stack-without new-idx)
|
||||
(list layer-props)
|
||||
(seq-drop stack-without new-idx))))
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(tp--build-layer-props new-stack)
|
||||
obj)))))
|
||||
start end obj)
|
||||
nil))
|
||||
|
||||
(defun tp-rotate-layer (start-or-string &optional end-or-object object)
|
||||
"Rotate layers, moving top layer to bottom.
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-rotate-layer START END OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-rotate-layer STRING)"
|
||||
(let (start end obj)
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)))
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-object
|
||||
obj object)))
|
||||
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(let ((current-stack (tp--layer-stack-to-list top belows)))
|
||||
(when (> (length current-stack) 1)
|
||||
(let ((new-stack (append (cdr current-stack) (list (car current-stack)))))
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(tp--build-layer-props new-stack)
|
||||
obj)))))
|
||||
start end obj)
|
||||
nil))
|
||||
|
||||
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
|
||||
"Pin a layer to the top (make it visible).
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-pin-layer START END IDX/LAYER-NAME OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-pin-layer STRING IDX/LAYER-NAME)"
|
||||
(let (start end layer-id obj)
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)
|
||||
layer-id end-or-idx))
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-idx
|
||||
layer-id idx-or-object
|
||||
obj object)))
|
||||
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
||||
(found (tp--get-layer-by-idx-or-name current-stack layer-id)))
|
||||
(when (and found (> (car found) 0))
|
||||
(let* ((layer-props (cdr found))
|
||||
(stack-without (-remove-at (car found) current-stack))
|
||||
(new-stack (cons layer-props stack-without)))
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(tp--build-layer-props new-stack)
|
||||
obj)))))
|
||||
start end obj)
|
||||
nil))
|
||||
|
||||
(defun tp-switch-layer (start-or-string &optional end-or-id1 id1-or-id2 id2-or-object object)
|
||||
"Switch between two layers by name or index.
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)"
|
||||
(let (start end id1 id2 obj)
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)
|
||||
id1 end-or-id1
|
||||
id2 id1-or-id2))
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-id1
|
||||
id1 id1-or-id2
|
||||
id2 id2-or-object
|
||||
obj object)))
|
||||
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
||||
(found1 (tp--get-layer-by-idx-or-name current-stack id1))
|
||||
(found2 (tp--get-layer-by-idx-or-name current-stack id2)))
|
||||
(when (and found1 found2)
|
||||
(let* ((idx1 (car found1))
|
||||
(idx2 (car found2))
|
||||
(props1 (cdr found1))
|
||||
(props2 (cdr found2))
|
||||
;; Swap the layers
|
||||
(new-stack (copy-sequence current-stack)))
|
||||
(setf (nth idx1 new-stack) props2)
|
||||
(setf (nth idx2 new-stack) props1)
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(tp--build-layer-props new-stack)
|
||||
obj)))))
|
||||
start end obj)
|
||||
nil))
|
||||
|
||||
(defun tp-merge-layers (start-or-string &optional end-or-name name-or-ids ids-or-object object)
|
||||
"Merge specified layers into a new layer.
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-merge-layers START END NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...) OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))"
|
||||
(let (start end new-name layer-ids obj)
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)
|
||||
new-name end-or-name
|
||||
layer-ids name-or-ids))
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-name
|
||||
new-name name-or-ids
|
||||
layer-ids ids-or-object
|
||||
obj object)))
|
||||
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
||||
;; Find all layers to merge
|
||||
(layers-to-merge
|
||||
(cl-loop for id in layer-ids
|
||||
for found = (tp--get-layer-by-idx-or-name current-stack id)
|
||||
when found collect found))
|
||||
;; Sort by index (descending) to remove from end first
|
||||
(sorted-layers (sort (copy-sequence layers-to-merge)
|
||||
(lambda (a b) (> (car a) (car b))))))
|
||||
(when layers-to-merge
|
||||
;; Merge properties (earlier in list takes precedence)
|
||||
(let* ((merged-props
|
||||
(cl-reduce (lambda (acc layer)
|
||||
(let ((props (cdr layer)))
|
||||
(cl-loop for (key val) on props by #'cddr
|
||||
do (unless (plist-get acc key)
|
||||
(setq acc (plist-put acc key val))))
|
||||
acc))
|
||||
layers-to-merge
|
||||
:initial-value (list 'tp-name new-name)))
|
||||
;; Remove old layers from stack
|
||||
(indices-to-remove (mapcar #'car sorted-layers))
|
||||
(new-stack current-stack))
|
||||
(dolist (idx indices-to-remove)
|
||||
(setq new-stack (-remove-at idx new-stack)))
|
||||
;; Add merged layer at top
|
||||
(setq new-stack (cons merged-props new-stack))
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(tp--build-layer-props new-stack)
|
||||
obj)))))
|
||||
start end obj)
|
||||
nil))
|
||||
|
||||
(defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object)
|
||||
"Flatten all layers into a single layer.
|
||||
|
||||
Calling conventions:
|
||||
1. Buffer/string region:
|
||||
(tp-flatten-layers START END NAME OBJECT)
|
||||
|
||||
2. Entire string:
|
||||
(tp-flatten-layers STRING NAME)
|
||||
|
||||
NAME can be nil for an unnamed layer."
|
||||
(let (start end name obj)
|
||||
(cond
|
||||
((stringp start-or-string)
|
||||
(setq obj start-or-string
|
||||
start 0
|
||||
end (length start-or-string)
|
||||
name end-or-name))
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
end end-or-name
|
||||
name name-or-object
|
||||
obj object)))
|
||||
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
||||
(layer-count (length current-stack)))
|
||||
(when (> layer-count 0)
|
||||
;; Create list of all indices
|
||||
(let ((all-ids (cl-loop for i from 0 below layer-count collect i)))
|
||||
;; Use merge with all layers
|
||||
(let* ((layers-to-merge
|
||||
(cl-loop for id in all-ids
|
||||
for found = (tp--get-layer-by-idx-or-name current-stack id)
|
||||
when found collect found))
|
||||
(merged-props
|
||||
(cl-reduce (lambda (acc layer)
|
||||
(let ((props (cdr layer)))
|
||||
(cl-loop for (key val) on props by #'cddr
|
||||
unless (eq key 'tp-name)
|
||||
do (unless (plist-get acc key)
|
||||
(setq acc (plist-put acc key val))))
|
||||
acc))
|
||||
layers-to-merge
|
||||
:initial-value (if name (list 'tp-name name) nil))))
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
merged-props
|
||||
obj))))))
|
||||
start end obj)
|
||||
nil))
|
||||
|
||||
;;; Layer query functions
|
||||
|
||||
(defun tp-layer-list (start end &optional object)
|
||||
"Return list of all layer names in region from START to END.
|
||||
OBJECT defaults to current buffer."
|
||||
(declare (indent defun))
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
;; If NAME is the top layer, promote the next layer
|
||||
(if (equal name (plist-get top 'tp-name))
|
||||
(append (nth 0 belows)
|
||||
(list 'tp-layers (seq-drop belows 1)))
|
||||
;; NAME is not the top layer, remove from belows
|
||||
(append top
|
||||
(list 'tp-layers
|
||||
(-remove (lambda (props)
|
||||
(equal name (plist-get props 'tp-name)))
|
||||
belows))))
|
||||
object))
|
||||
start end object)
|
||||
nil)
|
||||
(let ((layers nil))
|
||||
(tp-intervals-map
|
||||
(lambda (_i-start _i-end top belows)
|
||||
(when-let ((name (plist-get top 'tp-name)))
|
||||
(cl-pushnew name layers :test #'equal))
|
||||
(dolist (below belows)
|
||||
(when-let ((name (plist-get below 'tp-name)))
|
||||
(cl-pushnew name layers :test #'equal))))
|
||||
start end object)
|
||||
(nreverse layers)))
|
||||
|
||||
(defun tp-layer-rotate (start end &optional object)
|
||||
"Rotate layers from START to END, moving top layer to bottom.
|
||||
This cycles through the layer stack, making each layer visible in turn.
|
||||
(defun tp-layer-count (start end &optional object)
|
||||
"Return number of layers in region from START to END.
|
||||
OBJECT defaults to current buffer."
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(when belows
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(append (nth 0 belows)
|
||||
(list 'tp-layers
|
||||
(append (seq-drop belows 1)
|
||||
(list top))))
|
||||
object)))
|
||||
start end object)
|
||||
nil)
|
||||
(let ((max-count 0))
|
||||
(tp-intervals-map
|
||||
(lambda (_i-start _i-end top belows)
|
||||
(let ((count (+ (if top 1 0) (length belows))))
|
||||
(when (> count max-count)
|
||||
(setq max-count count))))
|
||||
start end object)
|
||||
max-count))
|
||||
|
||||
(defun tp-layer-pin (start end name &optional object)
|
||||
"Pin layer NAME to the top of the layer stack from START to END.
|
||||
Moves the layer named NAME to the top, making it visible.
|
||||
OBJECT defaults to current buffer.
|
||||
Signals an error if layer NAME does not exist in the region."
|
||||
(unless (tp-region-layer-props start end name object)
|
||||
(error "Doesn't exist a layer named %S" name))
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
;; Only do something if NAME is not already at top
|
||||
(unless (equal (plist-get top 'tp-name) name)
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(let ((new-top
|
||||
;; Find the layer to promote
|
||||
(seq-find (lambda (props)
|
||||
(equal (plist-get props 'tp-name) name))
|
||||
belows))
|
||||
;; Remove the promoted layer from belows
|
||||
(rest-belows
|
||||
(-remove (lambda (props)
|
||||
(equal (plist-get props 'tp-name) name))
|
||||
belows)))
|
||||
(append new-top
|
||||
(list 'tp-layers
|
||||
(append (list top) rest-belows))))
|
||||
object)))
|
||||
start end object)
|
||||
nil)
|
||||
(defun tp-layer-exists-p (start end name &optional object)
|
||||
"Return t if layer NAME exists in region from START to END.
|
||||
OBJECT defaults to current buffer."
|
||||
(not (null (tp-region-layer-props start end name object))))
|
||||
|
||||
(defun tp-layer-top (start end &optional object)
|
||||
"Return the name of the top layer at START in OBJECT.
|
||||
OBJECT defaults to current buffer."
|
||||
(when-let ((intervals (tp-intervals start end object)))
|
||||
(plist-get (nth 2 (car intervals)) 'tp-name)))
|
||||
|
||||
;;; Propertize functions (deprecated - use tp-set instead)
|
||||
|
||||
@ -1153,96 +1558,6 @@ PROPERTIES should be a plist of property-value pairs."
|
||||
|
||||
(make-obsolete 'tp-propertize 'tp-set "0.2.0")
|
||||
|
||||
(defun tp-layer-propertize (object layer &optional start end)
|
||||
"Apply LAYER properties to OBJECT.
|
||||
|
||||
OBJECT can be a string or buffer.
|
||||
LAYER must be defined in `tp-layer-alist'.
|
||||
|
||||
Calling conventions:
|
||||
1. String (full string):
|
||||
(tp-layer-propertize STRING LAYER)
|
||||
|
||||
2. String with range:
|
||||
(tp-layer-propertize STRING LAYER START END)
|
||||
|
||||
3. Buffer with range:
|
||||
(tp-layer-propertize BUFFER LAYER START END)
|
||||
|
||||
Returns the modified object."
|
||||
(if-let ((layer-info (assoc layer tp-layer-alist)))
|
||||
(let ((props (cdr layer-info)))
|
||||
(cond
|
||||
;; String without range - apply to whole string
|
||||
((and (stringp object) (null start))
|
||||
(apply #'propertize object props))
|
||||
;; String or buffer with range
|
||||
((or (stringp object) (bufferp object))
|
||||
(let ((beg (or start 0))
|
||||
(fin (or end (if (stringp object)
|
||||
(length object)
|
||||
(with-current-buffer object (point-max))))))
|
||||
(tp-put beg fin props object)
|
||||
object)) ; Always return the object
|
||||
(t (error "Invalid object type: %S" (type-of object)))))
|
||||
(error "Layer %S doesn't exist!" layer)))
|
||||
|
||||
(defun tp-group-propertize (object layer-group &optional start end)
|
||||
"Apply all layers from LAYER-GROUP to OBJECT.
|
||||
|
||||
OBJECT can be a string or buffer.
|
||||
LAYER-GROUP must be defined in `tp-layer-groups'.
|
||||
Layers are applied in order, with later layers on top.
|
||||
|
||||
Calling conventions:
|
||||
1. String (full string):
|
||||
(tp-group-propertize STRING LAYER-GROUP)
|
||||
|
||||
2. String with range:
|
||||
(tp-group-propertize STRING LAYER-GROUP START END)
|
||||
|
||||
3. Buffer with range:
|
||||
(tp-group-propertize BUFFER LAYER-GROUP START END)
|
||||
|
||||
Returns the modified object."
|
||||
(if-let* ((group-info (assoc layer-group tp-layer-groups))
|
||||
(layers (cdr group-info)))
|
||||
(let* ((beg (or start 0))
|
||||
(fin (or end (if (stringp object)
|
||||
(length object)
|
||||
(with-current-buffer object (point-max)))))
|
||||
(result (if (stringp object)
|
||||
(copy-sequence object)
|
||||
object)))
|
||||
;; Apply base layer first
|
||||
(when-let ((first-layer (car layers)))
|
||||
(if (stringp result)
|
||||
(setq result (tp-layer-propertize result first-layer beg fin))
|
||||
(tp-layer-propertize result first-layer beg fin)))
|
||||
;; Apply additional layers using the layer system
|
||||
(dolist (layer (cdr layers))
|
||||
(when-let ((props (tp-layer-props layer)))
|
||||
(if (stringp result)
|
||||
(set-text-properties beg fin
|
||||
(append props
|
||||
(list 'tp-layers
|
||||
(list (tp-at beg result))))
|
||||
result)
|
||||
(with-current-buffer result
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(set-text-properties
|
||||
(+ beg i-start) (+ beg i-end)
|
||||
(append props
|
||||
(list 'tp-layers (append (list top) belows)))
|
||||
result))
|
||||
beg fin result)))))
|
||||
result)
|
||||
(error "Layer group %S doesn't exist!" layer-group)))
|
||||
|
||||
(defalias 'tp-layer-group-propertize 'tp-group-propertize
|
||||
"Alias for `tp-group-propertize'.")
|
||||
|
||||
;;; Search functions
|
||||
|
||||
(defun tp-forward (property &optional value predicate not-current)
|
||||
@ -1540,117 +1855,6 @@ Unlike `tp-regexp', this deeply merges nested properties."
|
||||
(properties (cdr parsed)))
|
||||
(tp--regexp-apply pattern properties #'tp--deep-merge-apply object)))
|
||||
|
||||
;;; Layer list and query functions
|
||||
|
||||
(defun tp-layer-list (start end &optional object)
|
||||
"Return list of all layer names in region from START to END.
|
||||
OBJECT defaults to current buffer."
|
||||
(let ((layers nil))
|
||||
(tp-intervals-map
|
||||
(lambda (_i-start _i-end top belows)
|
||||
(when-let ((name (plist-get top 'tp-name)))
|
||||
(cl-pushnew name layers :test #'equal))
|
||||
(dolist (below belows)
|
||||
(when-let ((name (plist-get below 'tp-name)))
|
||||
(cl-pushnew name layers :test #'equal))))
|
||||
start end object)
|
||||
(nreverse layers)))
|
||||
|
||||
(defun tp-layer-count (start end &optional object)
|
||||
"Return number of layers in region from START to END.
|
||||
OBJECT defaults to current buffer."
|
||||
(let ((max-count 0))
|
||||
(tp-intervals-map
|
||||
(lambda (_i-start _i-end top belows)
|
||||
(let ((count (+ (if top 1 0) (length belows))))
|
||||
(when (> count max-count)
|
||||
(setq max-count count))))
|
||||
start end object)
|
||||
max-count))
|
||||
|
||||
(defun tp-layer-exists-p (start end name &optional object)
|
||||
"Return t if layer NAME exists in region from START to END.
|
||||
OBJECT defaults to current buffer."
|
||||
(not (null (tp-region-layer-props start end name object))))
|
||||
|
||||
(defun tp-layer-top (start end &optional object)
|
||||
"Return the name of the top layer at START in OBJECT.
|
||||
OBJECT defaults to current buffer."
|
||||
(when-let ((intervals (tp-intervals start end object)))
|
||||
(plist-get (nth 2 (car intervals)) 'tp-name)))
|
||||
|
||||
;;; Layer visibility functions
|
||||
|
||||
(defun tp-layer-hide (start end name &optional object)
|
||||
"Hide layer NAME by moving it below all other layers.
|
||||
OBJECT defaults to current buffer."
|
||||
(unless (tp-region-layer-props start end name object)
|
||||
(error "Doesn't exist a layer named %S" name))
|
||||
(tp-intervals-map
|
||||
(lambda (i-start i-end top belows)
|
||||
(if (equal (plist-get top 'tp-name) name)
|
||||
;; NAME is top, move it to bottom
|
||||
(when belows
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(append (nth 0 belows)
|
||||
(list 'tp-layers
|
||||
(append (seq-drop belows 1)
|
||||
(list top))))
|
||||
object))
|
||||
;; NAME is in belows, move it to bottom
|
||||
(let ((layer (seq-find (lambda (p)
|
||||
(equal name (plist-get p 'tp-name)))
|
||||
belows)))
|
||||
(when layer
|
||||
(set-text-properties
|
||||
(+ start i-start) (+ start i-end)
|
||||
(append top
|
||||
(list 'tp-layers
|
||||
(append (-remove (lambda (p)
|
||||
(equal name (plist-get p 'tp-name)))
|
||||
belows)
|
||||
(list layer))))
|
||||
object)))))
|
||||
start end object)
|
||||
nil)
|
||||
|
||||
(defun tp-layer-show (start end name &optional object)
|
||||
"Show layer NAME by moving it to the top.
|
||||
Alias for `tp-layer-pin'.
|
||||
OBJECT defaults to current buffer."
|
||||
(tp-layer-pin start end name object))
|
||||
|
||||
;;; Layer merge function
|
||||
|
||||
(defun tp-layer-merge (start end layer1 layer2 new-name &optional object)
|
||||
"Merge LAYER1 and LAYER2 into a new layer named NEW-NAME.
|
||||
Properties from LAYER1 take precedence over LAYER2.
|
||||
OBJECT defaults to current buffer."
|
||||
(let ((props1 (tp-region-layer-props start end layer1 object))
|
||||
(props2 (tp-region-layer-props start end layer2 object)))
|
||||
(unless (and props1 props2)
|
||||
(error "Both layers must exist in the region"))
|
||||
;; Get the properties from both layers
|
||||
(let* ((layer1-props (nth 2 (car props1)))
|
||||
(layer2-props (nth 2 (car props2)))
|
||||
;; Merge properties (layer1 takes precedence)
|
||||
(merged-props
|
||||
(let ((result (copy-sequence layer2-props)))
|
||||
(cl-loop for (key val) on layer1-props by #'cddr
|
||||
do (setq result (plist-put result key val)))
|
||||
(plist-put result 'tp-name new-name))))
|
||||
;; Delete old layers and push merged layer
|
||||
(tp-layer-delete start end layer1 object)
|
||||
(tp-layer-delete start end layer2 object)
|
||||
;; Define the new merged layer
|
||||
(if (assoc new-name tp-layer-alist)
|
||||
(setf (cdr (assoc new-name tp-layer-alist)) merged-props)
|
||||
(push (cons new-name merged-props) tp-layer-alist))
|
||||
;; Apply the merged layer
|
||||
(tp-layer-push start end new-name object)))
|
||||
nil)
|
||||
|
||||
;;; Utility functions
|
||||
|
||||
(defun tp-in (property &optional value start end)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user