Skip to content

Commit

Permalink
hydra.el (hydra--head-color): Remove
Browse files Browse the repository at this point in the history
* hydra.el (hydra-fontify-head-default): Move `hydra--head-color' body
  here.
(hydra-fontify-head-greyscale): Simplify.
(hydra--make-defun): Simplify.
(hydra--head-name): Simplify.
(hydra--delete-duplicates): Update.
(defhydra): Update.
  • Loading branch information
abo-abo committed Apr 13, 2015
1 parent d71386b commit 88f14a0
Show file tree
Hide file tree
Showing 2 changed files with 32 additions and 65 deletions.
26 changes: 0 additions & 26 deletions hydra-test.el
Original file line number Diff line number Diff line change
Expand Up @@ -1029,32 +1029,6 @@ _f_ auto-fill-mode: %`auto-fill-function
(buffer-narrowed-p)))
"[[q]]: cancel"))))

(ert-deftest hydra-compat-colors-1 ()
(should (equal (hydra--head-color
'("e" (message "Exiting now") "blue" :exit t)
'(nil nil :color blue))
'blue))
(should (equal (hydra--head-color
'("c" (message "Continuing") "red" :color red)
'(nil nil :color blue))
'red))
(should (equal (hydra--head-color
'("j" next-line "" :exit t)
'(nil nil))
'blue))
(should (equal (hydra--head-color
'("c" (message "Continuing") "red" :exit nil)
'(nil nil :exit t))
'red))
(equal (hydra--head-color
'("a" abbrev-mode nil :exit t)
'(nil nil :color teal))
'teal)
(equal (hydra--head-color
'("a" abbrev-mode :exit nil)
'(nil nil :color teal))
'amaranth))

(ert-deftest hydra-compat-colors-2 ()
(should
(equal
Expand Down
71 changes: 32 additions & 39 deletions hydra.el
Original file line number Diff line number Diff line change
Expand Up @@ -330,24 +330,6 @@ one of the properties on the list."
Return DEFAULT if PROP is not in H."
(hydra-plist-get-default (cl-cdddr h) prop default))

(defun hydra--head-color (h body)
"Return the color of a Hydra head H with BODY."
(let* ((foreign-keys (hydra--body-foreign-keys body))
(head-exit (hydra--head-property h :exit))
(head-color
(if head-exit
(if (eq foreign-keys 'warn)
'teal
'blue)
(cl-case foreign-keys
(warn 'amaranth)
(run 'pink)
(t 'red)))))
(when (and (null (cadr h))
(not (eq head-color 'blue)))
(hydra--complain "nil cmd can only be blue"))
head-color))

(defun hydra--body-foreign-keys (body)
"Return what BODY does with a non-head binding."
(or
Expand Down Expand Up @@ -423,23 +405,36 @@ BODY, and HEADS are parameters to `defhydra'."
(defun hydra-fontify-head-default (head body)
"Produce a pretty string from HEAD and BODY.
HEAD's binding is returned as a string with a colored face."
(propertize (car head) 'face
(cl-case (hydra--head-color head body)
(blue 'hydra-face-blue)
(red 'hydra-face-red)
(amaranth 'hydra-face-amaranth)
(pink 'hydra-face-pink)
(teal 'hydra-face-teal)
(t (error "Unknown color for %S" head)))))
(let* ((foreign-keys (hydra--body-foreign-keys body))
(head-exit (hydra--head-property head :exit))
(head-color
(if head-exit
(if (eq foreign-keys 'warn)
'teal
'blue)
(cl-case foreign-keys
(warn 'amaranth)
(run 'pink)
(t 'red)))))
(when (and (null (cadr head))
(not (eq head-color 'blue)))
(hydra--complain "nil cmd can only be blue"))
(propertize (car head) 'face
(cl-case head-color
(blue 'hydra-face-blue)
(red 'hydra-face-red)
(amaranth 'hydra-face-amaranth)
(pink 'hydra-face-pink)
(teal 'hydra-face-teal)
(t (error "Unknown color for %S" head))))))

(defun hydra-fontify-head-greyscale (head body)
"Produce a pretty string from HEAD and BODY.
HEAD's binding is returned as a string wrapped with [] or {}."
(let ((color (hydra--head-color head body)))
(format
(if (eq color 'blue)
"[%s]"
"{%s}") (car head))))
(format
(if (hydra--head-property head :exit)
"[%s]"
"{%s}") (car head)))

(defun hydra-fontify-head (head body)
"Produce a pretty string from HEAD and BODY."
Expand Down Expand Up @@ -533,8 +528,6 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
(cmd (when (car head)
(hydra--make-callable
(cadr head))))
(color (when (car head)
(hydra--head-color head body)))
(doc (if (car head)
(format "%s\n\nCall the head: `%S'." doc (cadr head))
doc))
Expand All @@ -546,7 +539,7 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
(interactive)
(hydra-default-pre)
,@(when body-pre (list body-pre))
,@(if (memq color '(blue teal))
,@(if (hydra--head-property head :exit)
`((hydra-keyboard-quit)
,(if body-after-exit
`(unwind-protect
Expand Down Expand Up @@ -586,23 +579,23 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
(if (symbolp (cadr h))
(cadr h)
(concat "lambda-" (car h))))))
(when (and (memq (hydra--head-color h body) '(blue teal))
(when (and (hydra--head-property h :exit)
(not (memq (cadr h) '(body nil))))
(setq str (concat str "-and-exit")))
(intern str)))

(defun hydra--delete-duplicates (heads)
"Return HEADS without entries that have the same CMD part.
In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
(let ((ali '(((hydra-repeat . red) . hydra-repeat)))
(let ((ali '(((hydra-repeat . nil) . hydra-repeat)))
res entry)
(dolist (h heads)
(if (setq entry (assoc (cons (cadr h)
(hydra--head-color h '(nil nil)))
(hydra--head-property h :exit))
ali))
(setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
(push (cons (cons (cadr h)
(hydra--head-color h '(nil nil)))
(hydra--head-property h :exit))
(plist-get (cl-cdddr h) :cmd-name))
ali)
(push h res)))
Expand Down Expand Up @@ -837,7 +830,7 @@ result of `defhydra'."
(when (memq body-foreign-keys '(run warn))
(unless (cl-some
(lambda (h)
(memq (hydra--head-color h body) '(blue teal)))
(hydra--head-property h :exit))
heads)
(error
"An %S Hydra must have at least one blue head in order to exit"
Expand Down

0 comments on commit 88f14a0

Please sign in to comment.