Skip to content

Commit

Permalink
Support glue navbar item
Browse files Browse the repository at this point in the history
  • Loading branch information
@papaeye
papaeye committed Feb 7, 2015
1 parent 0436172 commit 1e051f9
Show file tree
Hide file tree
Showing 2 changed files with 123 additions and 36 deletions.
95 changes: 73 additions & 22 deletions navbar.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -256,36 +256,79 @@ to concatenate the elements of the list."
value))

(defun navbar--item-serialize (item)
"Convert ITEM to a string. If ITEM has multiple values,
"Convert ITEM to a string if possible.
If an item value is a symbol, the symbol is returned as is.
If ITEM has multiple string values,
they are concatenated with `navbar-item-separator'."
(apply #'navbar--item-propertize
(mapconcat #'navbar--item-value-serialize
(navbar--item-value-normalize (plist-get item :value))
navbar-item-separator)
item))

(defun navbar-serialize (item-list)
"Convert ITEM-LIST to a string.
Each item is concatenated with `navbar-item-separator'.
(let ((value (plist-get item :value)))
(if (and (symbolp value) value)
value
(apply #'navbar--item-propertize
(mapconcat #'navbar--item-value-serialize
(navbar--item-value-normalize value)
navbar-item-separator)
item))))

(defun navbar--serialize (item-list)
"Convert ITEM-LIST to a list of item values.
An item value is converted to a string if possible.
The continuous elements of strings are concatenated with
`navbar-item-separator'.
Disabled items are ignored."
(mapconcat #'identity
(cl-loop for item in item-list
when (navbar--item-enabled-p item)
collect (navbar--item-serialize item))
navbar-item-separator))
(let (result value)
(dolist (item item-list (nreverse result))
(when (navbar--item-enabled-p item)
(setq value (navbar--item-serialize item))
(if (and (stringp value) (stringp (car result)))
(cl-callf concat (car result) navbar-item-separator value)
(push value result))))))

(defun navbar--expand-glues (values strings window)
(let ((max-width (window-body-width window t))
(line-width (with-selected-window window
(let (deactivate-mark)
(erase-buffer)
(insert (apply #'concat strings))
(car (window-text-pixel-size))))))
(if (>= line-width max-width)
strings
(let* ((space (- max-width line-width))
(num-glues (cl-loop for value in values
count (eq value 'glue)))
(q (/ space num-glues))
(r (% space num-glues))
glues)
(setq glues (make-list num-glues q))
(cl-incf (car glues) r)
(mapcar (lambda (value)
(if (eq value 'glue)
(propertize " " 'display `(space :width (,(pop glues))))
value))
values)))))

(defun navbar-display (item-list buffer)
"Display serialized ITEM-LIST in BUFFER."
(with-current-buffer buffer
(let (deactivate-mark)
(erase-buffer)
(insert (navbar-serialize item-list)))))
(let* ((values (navbar--serialize item-list))
(strings (cl-loop for value in values
when (stringp value)
collect value)))
(unless (equal values strings)
(setq strings (navbar--expand-glues
values strings (get-buffer-window buffer))))
(with-current-buffer buffer
(let (deactivate-mark)
(erase-buffer)
(insert (apply #'concat strings))))))

(defun navbar-update (&optional frame)
"Update navbar of FRAME."
(funcall navbar-display-function
(mapcar #'cdr navbar-item-alist)
(navbar-buffer frame)))
(unless frame
(setq frame (selected-frame)))
(with-selected-frame frame
(funcall navbar-display-function
(mapcar #'cdr navbar-item-alist)
(navbar-buffer frame))))

(defun navbar--funcall-with-no-display (function &rest arguments)
(let ((navbar-display-function #'ignore))
Expand Down Expand Up @@ -441,6 +484,7 @@ Also, this runs :deinitialize functions without updating the navbar buffer."
(navbar-advices-setup)
(add-hook 'after-make-frame-functions #'navbar-update)
(add-hook 'after-make-frame-functions #'navbar-make-window)
(add-hook 'window-size-change-functions #'navbar-update)
(mapc #'navbar-make-window (frame-list))
(navbar-initialize)
(mapc #'navbar-update (frame-list))
Expand All @@ -451,6 +495,7 @@ Also, this runs :deinitialize functions without updating the navbar buffer."
(navbar-advices-teardown)
(remove-hook 'after-make-frame-functions #'navbar-update)
(remove-hook 'after-make-frame-functions #'navbar-make-window)
(remove-hook 'window-size-change-functions #'navbar-update)
(mapc 'navbar-kill-buffer-and-window (frame-list))
(font-lock-remove-keywords 'emacs-lisp-mode navbar-font-lock-keywords))

Expand All @@ -462,5 +507,11 @@ Also, this runs :deinitialize functions without updating the navbar buffer."
(navbar-setup)
(navbar-teardown)))

;;; Navbar items

(navbar-define-item navbarx-glue
"Navbar item for glue."
:value 'glue)

(provide 'navbar)
;;; navbar.el ends here
64 changes: 50 additions & 14 deletions test/navbar-test.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -314,14 +314,22 @@

;;;; `navbar--item-serialize'

(ert-deftest navbar--item-serialize/single-value ()
(ert-deftest navbar--item-serialize/string-value ()
(should (string= (navbar--item-serialize '(:value "foo"))
"foo")))

(ert-deftest navbar--item-serialize/multiple-values ()
(ert-deftest navbar--item-serialize/multiple-string-values ()
(should (string= (navbar--item-serialize '(:value ("foo" "bar")))
"foo bar")))

(ert-deftest navbar--item-serialize/symbol-value ()
(should (string= (navbar--item-serialize '(:value foo))
'foo)))

(ert-deftest navbar--item-serialize/nil-value ()
(should (string= (navbar--item-serialize '(:value nil))
"")))

(ert-deftest navbar--item-serialize/property/item-value ()
(should (string= (navbar--item-serialize '(:value ("foobar" :truncate 5)))
"fo...")))
Expand All @@ -342,20 +350,46 @@
:truncate 10)))
"fo...ba...")))

;;;; `navbar-serialize'
;;;; `navbar--serialize'

(ert-deftest navbar-serialize/string-value ()
(should (string= (navbar-serialize '((:value "foo")))
"foo")))
(ert-deftest navbar-serialize/string-values ()
(should (equal (navbar--serialize '((:value ("foo" "bar"))
(:value "baz")))
'("foo bar baz"))))

(ert-deftest navbar-serialize/list-value ()
(should (string= (navbar-serialize '((:value ("foo" "bar"))))
"foo bar")))
(ert-deftest navbar-serialize/symbol ()
(should (equal (navbar--serialize '((:value "foo") (:value "bar")
(:value baz)))
'("foo bar" baz))))

(ert-deftest navbar-serialize/nil ()
(should (equal (navbar--serialize '((:value "foo") nil (:value "bar")))
'("foo bar"))))

(ert-deftest navbar-serialize/ignore-disabled-item ()
(should (string= (navbar-serialize '((:value "foo")
(:value "bar" :enable nil)))
"foo")))
(should (equal (navbar--serialize '((:value "foo") (:value "bar")
(:value "bar" :enable nil)))
'("foo bar"))))

;;;; `navbar-display'

(ert-deftest navbar-display/strings ()
(with-temp-buffer
(navbar-display '((:value "foo") (:value "bar")) (current-buffer))
(should (string= (buffer-string) "foo bar"))))

(ert-deftest navbar-display/glue ()
(save-window-excursion
(switch-to-buffer (current-buffer))
(let ((glue-width (- (window-body-width nil t)
(let (deactivate-mark)
(erase-buffer)
(insert "foo")
(car (window-text-pixel-size))))))
(navbar-display '((:value glue) (:value "foo")) (current-buffer))
(should (string= (buffer-string) " foo"))
(should (equal (get-text-property 0 'display (buffer-string))
`(space :width (,glue-width)))))))

;;;; `navbar-initialize'

Expand Down Expand Up @@ -565,9 +599,11 @@
(ert-deftest navbar-mode/hooks ()
(navbar-test-with-mode navbar-mode
(should (memq 'navbar-update after-make-frame-functions))
(should (memq 'navbar-make-window after-make-frame-functions)))
(should (memq 'navbar-make-window after-make-frame-functions))
(should (memq 'navbar-update window-size-change-functions)))
(should-not (memq 'navbar-update after-make-frame-functions))
(should-not (memq 'navbar-make-window after-make-frame-functions)))
(should-not (memq 'navbar-make-window after-make-frame-functions))
(should-not (memq 'navbar-update window-size-change-functions)))

(unless noninteractive
(ert-deftest navbar-mode/multiple-frames ()
Expand Down

0 comments on commit 1e051f9

Please sign in to comment.