first commit
This commit is contained in:
Kinneyzhang
parent
349a3eecef
commit
9fd5ba552f
59
tp-tests-utils.el
Normal file
59
tp-tests-utils.el
Normal file
@ -0,0 +1,59 @@
|
|||||||
|
(defvar pop-buffer-insert-buffer
|
||||||
|
"*pop-buffer-insert*")
|
||||||
|
|
||||||
|
(defvar pop-buffer-win-conf nil)
|
||||||
|
|
||||||
|
(defun my-pop-to-buffer (buffer-or-name &optional action norecord)
|
||||||
|
(declare (indent defun))
|
||||||
|
(let ((buffer (pop-to-buffer buffer-or-name action norecord)))
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(local-set-key "q" 'pop-buffer-quit))
|
||||||
|
buffer))
|
||||||
|
|
||||||
|
(defun remove-from-list (list-var element)
|
||||||
|
(set list-var (delete element (symbol-value list-var))))
|
||||||
|
|
||||||
|
(defun pop-buffer-quit ()
|
||||||
|
(interactive)
|
||||||
|
(let ((win-conf pop-buffer-win-conf))
|
||||||
|
(local-unset-key "q")
|
||||||
|
(setq-local pop-buffer-win-conf nil)
|
||||||
|
(remove-from-list 'margin-work-modes 'quick-buffer-mode)
|
||||||
|
(set-window-configuration win-conf)))
|
||||||
|
|
||||||
|
(defmacro with-pop-buffer (buffer-or-name height &rest body)
|
||||||
|
(declare (indent defun))
|
||||||
|
`(let* ((win-conf (current-window-configuration))
|
||||||
|
(height ,height)
|
||||||
|
(buffer (my-pop-to-buffer ,buffer-or-name
|
||||||
|
`(,@(if height
|
||||||
|
`(display-buffer-at-bottom
|
||||||
|
(cons window-height height))
|
||||||
|
`(display-buffer-full-frame))))))
|
||||||
|
(add-to-list 'margin-work-modes 'quick-buffer-mode)
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(setq major-mode 'quick-buffer-mode)
|
||||||
|
(setq-local pop-buffer-win-conf win-conf)
|
||||||
|
(let ((inhibit-read-only t))
|
||||||
|
(erase-buffer)
|
||||||
|
,@body)
|
||||||
|
(read-only-mode 1))))
|
||||||
|
|
||||||
|
(defun pop-buffer-insert (height &rest body)
|
||||||
|
(declare (indent defun))
|
||||||
|
(if (member pop-buffer-insert-buffer
|
||||||
|
(mapcar #'buffer-name (window-buffers)))
|
||||||
|
(let ((inhibit-read-only t))
|
||||||
|
(select-window (get-buffer-window
|
||||||
|
pop-buffer-insert-buffer))
|
||||||
|
(erase-buffer)
|
||||||
|
(apply #'insert body))
|
||||||
|
(with-pop-buffer pop-buffer-insert-buffer height
|
||||||
|
(apply #'insert body))))
|
||||||
|
|
||||||
|
(defmacro pop-buffer-do (height &rest body)
|
||||||
|
(declare (indent defun))
|
||||||
|
`(with-pop-buffer ,pop-buffer-insert-buffer ,height
|
||||||
|
,@body))
|
||||||
|
|
||||||
|
(provide 'tp-tests-utils)
|
||||||
84
tp-tests.el
Normal file
84
tp-tests.el
Normal file
@ -0,0 +1,84 @@
|
|||||||
|
(require 'tp-tests-utils)
|
||||||
|
|
||||||
|
;; tp-layer-alist
|
||||||
|
;; tp-layer-groups
|
||||||
|
|
||||||
|
(tp-layer-define 'test1
|
||||||
|
'(face link :foreground "orange"))
|
||||||
|
|
||||||
|
(tp-layer-define 'test2
|
||||||
|
'(face link :foreground "cyan"))
|
||||||
|
|
||||||
|
(tp-layer-group-define 'test-group
|
||||||
|
'(test1 display "this is top layer"
|
||||||
|
face (:background "red" :foreground "#000"))
|
||||||
|
'(test2 display "this is middle layer"
|
||||||
|
face (:background "green" :foreground "#000"))
|
||||||
|
'(test3 display "this is bottom layer"
|
||||||
|
face (:background "cyan" :foreground "#000")))
|
||||||
|
|
||||||
|
(tp-layer-propertize "emacs" 'test1)
|
||||||
|
(tp-layer-group-propertize "emacs" 'test-group)
|
||||||
|
|
||||||
|
(defun tp-tests-layer-rotate (&optional btn)
|
||||||
|
(interactive)
|
||||||
|
(let ((inhibit-read-only t))
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(tp-layer-rotate (line-beginning-position)
|
||||||
|
(line-end-position)))))
|
||||||
|
|
||||||
|
(pop-buffer-do nil
|
||||||
|
(insert (tp-layer-group-propertize "emacs" 'test-group)
|
||||||
|
"\n\n")
|
||||||
|
(insert-text-button
|
||||||
|
" eval (tp-tests-layer-rotate) "
|
||||||
|
'action 'tp-tests-layer-rotate
|
||||||
|
'face '(:box t)
|
||||||
|
'follow-link t))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(pop-buffer-insert nil
|
||||||
|
(propertize
|
||||||
|
" "
|
||||||
|
'display ""
|
||||||
|
'face '(:underline (:position t :color "grey")))
|
||||||
|
" "
|
||||||
|
(propertize
|
||||||
|
"hacking"
|
||||||
|
'face '(:foreground "cyan"))
|
||||||
|
" "
|
||||||
|
(propertize
|
||||||
|
"emacs"
|
||||||
|
'face '(:slant italic :background "orange")))
|
||||||
|
|
||||||
|
(with-current-buffer pop-buffer-insert-buffer
|
||||||
|
(erase-buffer)
|
||||||
|
(tp-tests-run))
|
||||||
|
|
||||||
|
(with-current-buffer pop-buffer-insert-buffer
|
||||||
|
(let ((inhibit-read-only 1))
|
||||||
|
;; (tp-all (point-min) (point-max))
|
||||||
|
(tp-layer-set 'default (point-min) (point-max))
|
||||||
|
(tp-layer-push 1
|
||||||
|
(point-min) (point-max)
|
||||||
|
'( face (:background "green" :foreground "grey")
|
||||||
|
display (height 1.2)))
|
||||||
|
|
||||||
|
(tp-layer-push 2
|
||||||
|
(point-min) (point-max)
|
||||||
|
'(face (:background "orange" :foreground "#000")))
|
||||||
|
|
||||||
|
(tp-layer-push 3
|
||||||
|
(point-min) (point-max)
|
||||||
|
'(face (:weight bold :background "SlateBlue2")))))
|
||||||
|
|
||||||
|
(with-current-buffer pop-buffer-insert-buffer
|
||||||
|
(let ((inhibit-read-only 1))
|
||||||
|
;; (tp-layer-demote (point-min) (point-max))
|
||||||
|
;; (tp-layer-rotate (point-min) (point-max))
|
||||||
|
;; (tp-layer-delete 2 (point-min) (point-max))
|
||||||
|
;; (tp-layer-pin 1 (point-min) (point-max))
|
||||||
|
;; (tp-layer-pin '3 1 16)
|
||||||
|
))
|
||||||
231
tp.el
Normal file
231
tp.el
Normal file
@ -0,0 +1,231 @@
|
|||||||
|
;; 对 text properties 的封装
|
||||||
|
;; elisp 原生的 text properties 函数的局限性
|
||||||
|
;; https://github.com/emacsorphanage/ov
|
||||||
|
|
||||||
|
(require 'dash)
|
||||||
|
|
||||||
|
;;; tp layer
|
||||||
|
|
||||||
|
(defun tp-top-layer-props (properties)
|
||||||
|
"获取最上面的属性层，也就是实际要渲染的层"
|
||||||
|
(if-let ((idx (-elem-index 'tp-layers properties)))
|
||||||
|
(-remove-at-indices (list idx (1+ idx)) properties)
|
||||||
|
properties))
|
||||||
|
|
||||||
|
(defun tp-below-layers-props (properties)
|
||||||
|
"获取最上层以下的属性层列表"
|
||||||
|
(plist-get properties 'tp-layers))
|
||||||
|
|
||||||
|
(defun tp-all (start end &optional object)
|
||||||
|
"获取 OBJECT 的 start 到 end 范围内文本的所有 text properties。
|
||||||
|
OBJECT 可以为 buffer 或 string，nil 默认为当前 buffer。
|
||||||
|
point 从 0 开始。"
|
||||||
|
(let ((object (or object (current-buffer))))
|
||||||
|
(cond
|
||||||
|
((stringp object)
|
||||||
|
(object-intervals (substring object start end)))
|
||||||
|
((bufferp object)
|
||||||
|
(with-current-buffer (get-buffer-create object)
|
||||||
|
(object-intervals (buffer-substring start end))))
|
||||||
|
(t (error "Invalid format of object: %S"
|
||||||
|
(type-of object))))))
|
||||||
|
|
||||||
|
(defun tp-empty-p (object)
|
||||||
|
(null (object-intervals object)))
|
||||||
|
|
||||||
|
(defun tp-intervals-map (function start end &optional object)
|
||||||
|
"处理 start，end 之间的所有 intervals 的文本属性
|
||||||
|
function 的四个参数分别为:区间开始位置，区间结束位置，顶层属性和下层属性列表"
|
||||||
|
(remove
|
||||||
|
nil
|
||||||
|
(mapcar
|
||||||
|
(lambda (tp)
|
||||||
|
(let* ((interval-start (nth 0 tp)) ;; start from 0
|
||||||
|
(interval-end (nth 1 tp))
|
||||||
|
(interval-props (nth 2 tp))
|
||||||
|
(top-props (tp-top-layer-props interval-props))
|
||||||
|
(below-props-lst (tp-below-layers-props interval-props)))
|
||||||
|
(funcall function
|
||||||
|
interval-start interval-end
|
||||||
|
top-props below-props-lst)))
|
||||||
|
(tp-all start end object))))
|
||||||
|
|
||||||
|
(defun tp-layer-props (name start end &optional object)
|
||||||
|
"返回 object 的 start 和 end 之间文本属性层为 name 的属性列表"
|
||||||
|
(tp-intervals-map
|
||||||
|
(lambda (i-start i-end top belows)
|
||||||
|
(when-let ((props (seq-find
|
||||||
|
(lambda (props)
|
||||||
|
(equal name (plist-get props 'tp-name)))
|
||||||
|
(append (list top) belows))))
|
||||||
|
(list (+ start i-start) (+ start i-end) props)))
|
||||||
|
start end object))
|
||||||
|
|
||||||
|
;; (defun tp-layers-names (start end &optional object)
|
||||||
|
;; "返回当前所有 layers 的名称"
|
||||||
|
;; (seq-uniq
|
||||||
|
;; (apply 'append
|
||||||
|
;; (tp-intervals-map
|
||||||
|
;; (lambda (i-start i-end top belows)
|
||||||
|
;; (remove nil (mapcar (lambda (props)
|
||||||
|
;; (plist-get props 'tp-name))
|
||||||
|
;; (append (list top) belows))))
|
||||||
|
;; start end object))))
|
||||||
|
|
||||||
|
(defun tp-layer-set (name start end &optional object)
|
||||||
|
"将 object 的 start 和 end 之间的文本当前的属性层命名为 name"
|
||||||
|
(if (tp-empty-p object)
|
||||||
|
(add-text-properties
|
||||||
|
start end (list 'tp-name name) end 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)
|
||||||
|
|
||||||
|
(defun tp-layer-push (name start end properties &optional object)
|
||||||
|
"设置 properties 为最上面的 prop 层，name 是 layer 的名字"
|
||||||
|
;; 当前顶层放到 tp-layers 开头，properties 设置为当前顶层。
|
||||||
|
;; FIXME: 需要检查 name 是否已经存在，存在则报错
|
||||||
|
(declare (indent defun))
|
||||||
|
(when (tp-layer-props name start end object)
|
||||||
|
(error "Already exist layer named %S" name))
|
||||||
|
(if (tp-empty-p object)
|
||||||
|
(set-text-properties
|
||||||
|
start end (append properties (list 'tp-name name))
|
||||||
|
object)
|
||||||
|
(tp-intervals-map
|
||||||
|
(lambda (i-start i-end top belows)
|
||||||
|
(set-text-properties
|
||||||
|
(+ start i-start) (+ start i-end)
|
||||||
|
(append (append properties (list 'tp-name name))
|
||||||
|
(list 'tp-layers (append (list top) belows)))
|
||||||
|
object))
|
||||||
|
start end object))
|
||||||
|
object)
|
||||||
|
|
||||||
|
(defun tp-layer-delete (name start end &optional object)
|
||||||
|
"移除 object 的 start 和 end 之间文本的名称为 name 的层"
|
||||||
|
;; 当前顶层放到 tp-layers 开头，properties 设置为当前顶层。
|
||||||
|
;; FIXME: 需要检查 name 是否已经存在，存在则报错
|
||||||
|
(declare (indent defun))
|
||||||
|
(tp-intervals-map
|
||||||
|
(lambda (i-start i-end top belows)
|
||||||
|
(set-text-properties
|
||||||
|
(+ start i-start) (+ start i-end)
|
||||||
|
;; name 是顶层，删除该层后，下一层上移
|
||||||
|
(if (equal name (plist-get top 'tp-name))
|
||||||
|
(append (nth 0 belows)
|
||||||
|
(list 'tp-layers (seq-drop belows 1)))
|
||||||
|
;; name 不是顶层，直接删除
|
||||||
|
(append top
|
||||||
|
(list 'tp-layers
|
||||||
|
(-remove (lambda (props)
|
||||||
|
(equal name (plist-get
|
||||||
|
props 'tp-name)))
|
||||||
|
belows))))
|
||||||
|
object))
|
||||||
|
start end object)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun tp-layer-rotate (start end &optional object)
|
||||||
|
"将 start 和 end 之间的顶层文本属性移到最后一层，相当于循环显示不同层。"
|
||||||
|
(tp-intervals-map
|
||||||
|
(lambda (i-start i-end top 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)
|
||||||
|
|
||||||
|
(defun tp-layer-pin (name start end &optional object)
|
||||||
|
"将 start 和 end 之间名称为 name 的层移动最上面。"
|
||||||
|
(unless (tp-layer-props name start end object)
|
||||||
|
(error "Doesn't exist a layer named %S" name))
|
||||||
|
(tp-intervals-map
|
||||||
|
(lambda (i-start i-end top belows)
|
||||||
|
;; name layer 本身就位于最上层时，无需操作
|
||||||
|
(unless (equal (plist-get top 'tp-name) name)
|
||||||
|
(set-text-properties
|
||||||
|
(+ start i-start) (+ start i-end)
|
||||||
|
(let ((new-top
|
||||||
|
;; 获取新的置顶层
|
||||||
|
(seq-find (lambda (props)
|
||||||
|
(equal (plist-get props 'tp-name)
|
||||||
|
name))
|
||||||
|
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)
|
||||||
|
|
||||||
|
;;; propertize string
|
||||||
|
|
||||||
|
(defvar tp-layer-alist nil
|
||||||
|
"Alist 的每个元素是单个 layer")
|
||||||
|
|
||||||
|
(defvar tp-layer-groups nil
|
||||||
|
"group 的每个元素是 layer 组，组中存储的是多个 layer")
|
||||||
|
|
||||||
|
(defun tp-layer-define (name properties)
|
||||||
|
"定义一个名称为 name 的文本属性层，数据存放在 tp-layer-alist 中"
|
||||||
|
(declare (indent defun))
|
||||||
|
(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))
|
||||||
|
|
||||||
|
(defun tp-layer-group-define (name &rest layers)
|
||||||
|
"每个属性层在 tp-layer-alist 中，属性组指在 tp-layer-groups 中存储属性层的名称
|
||||||
|
层级关系与layers定义顺序一致。最上面的定义表示顶层，渲染时会显示出来。"
|
||||||
|
(declare (indent defun))
|
||||||
|
(let ((layer-names
|
||||||
|
(nreverse
|
||||||
|
(mapcar (lambda (layer)
|
||||||
|
(let ((layer-name (car layer)))
|
||||||
|
(tp-layer-define layer-name (cdr layer))
|
||||||
|
layer-name))
|
||||||
|
layers))))
|
||||||
|
(if (assoc name tp-layer-groups)
|
||||||
|
(setf (cdr (assoc name tp-layer-groups)) layer-names)
|
||||||
|
(push (cons name layer-names) tp-layer-groups))))
|
||||||
|
|
||||||
|
(defun tp-propertize (string properties &optional layer)
|
||||||
|
(declare (indent defun))
|
||||||
|
(let ((layer (or layer (org-id-uuid))))
|
||||||
|
(tp-layer-push layer
|
||||||
|
0 (length string) properties string)
|
||||||
|
string))
|
||||||
|
|
||||||
|
(defun tp-layer-propertize (string layer)
|
||||||
|
(if-let ((layer-info (assoc layer tp-layer-alist)))
|
||||||
|
(tp-propertize string
|
||||||
|
(cdr layer-info) (car layer-info))
|
||||||
|
(error "layer %S doesn't exist!" layer)))
|
||||||
|
|
||||||
|
(defun tp-layer-group-propertize (string layer-group)
|
||||||
|
(if-let* ((group-info (assoc layer-group tp-layer-groups))
|
||||||
|
(layers (cdr group-info)))
|
||||||
|
(progn
|
||||||
|
(dolist (layer layers)
|
||||||
|
(setq string (tp-layer-propertize string layer)))
|
||||||
|
string)
|
||||||
|
(error "layer group %S doesn't exist!" layer-group)))
|
||||||
|
|
||||||
|
(provide 'tp)
|
||||||
Loading…
Reference in New Issue
Block a user