branch: externals/hyperbole
commit 7a86ea33e246c66a9e5fdcd98a219d2ec9bb87e9
Author: Bob Weiner <r...@gnu.org>
Commit: Bob Weiner <r...@gnu.org>
Add ibut:create and allow Assist Key :help for Elisp functions
---
ChangeLog | 13 ++++++
hact.el | 8 ++--
hbut.el | 129 +++++++++++++++++++++++++++++++++++++-----------------------
hibtypes.el | 55 +++++++++++++++++---------
4 files changed, 134 insertions(+), 71 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index b68deaa062..21b4c9bfe5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -3,6 +3,8 @@
to return search expression rather than doing the search. Use
with Assist Key.
+* hibtypes.el (action): Call ibut:create to ensure button attributes
+ are set properly.
* test/demo-tests.el (fast-demo-key-series-shell-pushd-hyperb-dir,
fast-demo-key-series-shell-grep,
fast-demo-key-series-shell-apropos):
@@ -66,6 +68,11 @@
(hypb:function-symbol-replace, hypb:map-sublists)
(hypb:constant-vector-symbol-replace): Delete functions.
+* hbut.el (ibut:create): Add, extracted from 'ibut:at-p'; define
+ with cl-defun so can optionally use non-positional colon-prefixed
+ keyword args to specify specific args.
+
+* hmouse-drv.el (hkey-help): Set 'assist-flag' so matches Assist Key
2022-07-12 Mats Lidell <ma...@gnu.org>
* test/hpath-tests.el (hpath:auto-variable-alist-load-path-test): Simplify
@@ -74,6 +81,12 @@
* test/hui-tests.el (hui-gbut-edit-link-to-file-button): Remove test file
after test case is completed.
+2022-07-11 Bob Weiner <r...@gnu.org>
+
+* hibtypes.el (action:help): Allow for action button assist key :help
+ functions, even if the action button type is not a Hyperbole type,
+ i.e. a regular function.
+
2022-07-11 Mats Lidell <ma...@gnu.org>
* test/hy-test-helpers.el (hy-test-helpers:should-last-message): Use
diff --git a/hact.el b/hact.el
index edc16f2798..131bf9c22f 100644
--- a/hact.el
+++ b/hact.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 18-Sep-91 at 02:57:09
-;; Last-Mod: 30-May-22 at 13:55:46 by Bob Weiner
+;; Last-Mod: 17-Jul-22 at 12:58:33 by Bob Weiner
;;
;; Copyright (C) 1991-2021 Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
@@ -264,8 +264,10 @@ When optional SYM is given, returns the name for that
symbol only, if any."
;;; ------------------------------------------------------------------------
(defun htype:symbol (type type-category)
- "Return possibly new Hyperbole type symbol composed from TYPE and
TYPE-CATEGORY (both symbols)."
- (intern (concat (symbol-name type-category) "::" (symbol-name type))))
+ "Return possibly new Hyperbole type symbol composed from TYPE and
TYPE-CATEGORY (both symbols).
+TYPE-CATEGORY must be one of `actypes' or `ibtypes'; if not, return nil."
+ (when (memq type-category '(actypes ibtypes))
+ (intern (concat (symbol-name type-category) "::" (symbol-name type)))))
;;; ========================================================================
;;; action class
diff --git a/hbut.el b/hbut.el
index 10fe130fc0..2f8568b60c 100644
--- a/hbut.el
+++ b/hbut.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 18-Sep-91 at 02:57:09
-;; Last-Mod: 15-Jul-22 at 22:07:35 by Mats Lidell
+;; Last-Mod: 17-Jul-22 at 16:26:56 by Bob Weiner
;;
;; Copyright (C) 1991-2022 Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
@@ -17,8 +17,8 @@
;;; Other required Elisp libraries
;;; ************************************************************************
-(eval-and-compile (mapc #'require '(elisp-mode help-mode hversion hmoccur
- hbmap htz hbdata hact view)))
+(eval-and-compile (mapc #'require '(cl-lib elisp-mode help-mode hversion
+ hmoccur hbmap htz hbdata hact view)))
;;; ************************************************************************
;;; Public declarations
@@ -1519,52 +1519,11 @@ excluding delimiters, not just one."
;; should need that.
(goto-char (min (+ 2 (match-end 0)) (point-max)))
(goto-char opoint))))
-
- ;; Check for an implicit button at current point, record its
- ;; attributes and return a button symbol for it.
- (let ((types (htype:category 'ibtypes))
- ;; Global var used in (hact) function, don't delete.
- (hrule:action 'actype:identity)
- (ibpoint (point-marker))
- (itype)
- (args)
- (is-type))
- (unless key-only
- (hattr:clear 'hbut:current))
- (while (and (not is-type) types)
- (setq itype (car types))
- (when (and itype (setq args (funcall itype)))
- (setq is-type itype)
- ;; Any implicit button type check should leave point
- ;; unchanged. Trigger an error if not.
- (unless (equal (point-marker) ibpoint)
- (hypb:error "(Hyperbole): `ibtypes::%s' implicit button
type test failed to restore point to %s" is-type ibpoint)))
- (setq types (cdr types)))
- (set-marker ibpoint nil)
- (when is-type
- (when name
- (hattr:set 'hbut:current 'name name))
- (hattr:set 'hbut:current 'categ is-type)
- (when lbl-key
- (hattr:set 'hbut:current 'lbl-key lbl-key))
- (if key-only
- (hattr:get 'hbut:current 'lbl-key)
- (hattr:set 'hbut:current 'loc (save-excursion
- (hbut:key-src 'full)))
- (or (hattr:get 'hbut:current 'args)
- (not (listp args))
- (progn
- (setq args (copy-sequence args))
- (when (eq (car args) #'hact)
- (setq args (cdr args)))
- (hattr:set 'hbut:current 'actype
- (or
- ;; Hyperbole action type
- (symtable:actype-p (car args))
- ;; Regular Emacs Lisp function symbol
- (car args)))
- (hattr:set 'hbut:current 'args (cdr args))))
- 'hbut:current))))
+ (if key-only
+ lbl-key
+ ;; Check for an implicit button at current point, record its
+ ;; attributes and return a button symbol for it.
+ (ibut:create)))
(goto-char opoint)))))
(defun ibut:at-type-p (ibut-type-symbol)
@@ -1583,6 +1542,78 @@ associated arguments from the button."
(hrule:action 'actype:identity))
(funcall ibut-type-symbol))))))
+(cl-defun ibut:create (&optional &key name lbl-key lbl-start lbl-end
+ loc categ actype args action)
+ "Return `hbut:current' symbol with attributes of implicit button at point.
+Return nil if no implicit button at point."
+ ;; :args is ignored unless :categ is also given.
+
+ ;; Since the Smart Keys handle end-of-line and end-of-buffer
+ ;; separately from whether point is within an implicit button,
+ ;; always report not within one when point is at the end of a line.
+ ;; -- RSW, 02-16-2020 and 07-17-2022
+ (unless (or (eolp) (eobp))
+ (let* ((types (htype:category 'ibtypes))
+ ;; Global var used in (hact) function, don't delete.
+ (hrule:action 'actype:identity)
+ (name-start-end (ibut:label-p t nil nil t t))
+ (ibpoint (point-marker))
+ (itype)
+ (is-type categ))
+
+ (unless name
+ (setq name (nth 0 name-start-end)))
+ (unless lbl-key
+ (setq lbl-key (or (ibut:label-to-key name)
+ (ibut:label-p nil "\"" "\"" nil))))
+ (unless lbl-start
+ (setq lbl-start (nth 1 name-start-end)))
+ (unless lbl-end
+ (setq lbl-end (nth 2 name-start-end)))
+
+ (hattr:clear 'hbut:current)
+ (unless is-type
+ (while (and (not is-type) types)
+ (setq itype (car types))
+ (when (and itype (setq args (funcall itype)))
+ (setq is-type itype)
+ ;; Any implicit button type check should leave point
+ ;; unchanged. Trigger an error if not.
+ (unless (equal (point-marker) ibpoint)
+ (hypb:error "(Hyperbole): `ibtypes::%s' implicit button type test
failed to restore point to %s" is-type ibpoint)))
+ (setq types (cdr types))))
+
+ (set-marker ibpoint nil)
+ (when is-type
+ (when name
+ (hattr:set 'hbut:current 'name name))
+ (when lbl-start
+ (hattr:set 'hbut:current 'lbl-start lbl-start))
+ (when lbl-end
+ (hattr:set 'hbut:current 'lbl-end lbl-end))
+ (hattr:set 'hbut:current 'categ is-type)
+ (when lbl-key
+ (hattr:set 'hbut:current 'lbl-key lbl-key))
+ (hattr:set 'hbut:current 'loc (or loc (save-excursion
+ (hbut:key-src 'full))))
+ (when action
+ (hattr:set 'hbut:current 'action action))
+ (or args
+ (hattr:get 'hbut:current 'args)
+ (not (listp args))
+ (progn
+ (setq args (copy-sequence args))
+ (when (eq (car args) #'hact)
+ (setq args (cdr args)))
+ (hattr:set 'hbut:current 'actype
+ (or
+ ;; Hyperbole action type
+ (symtable:actype-p (car args))
+ ;; Regular Emacs Lisp function symbol
+ (car args)))
+ (hattr:set 'hbut:current 'args (cdr args))))
+ 'hbut:current))))
+
(defun ibut:delete (&optional but-sym)
"Delete Hyperbole implicit button based on optional BUT-SYM.
Default is `hbut:current'.
diff --git a/hibtypes.el b/hibtypes.el
index cee63a9786..a366ab30c2 100644
--- a/hibtypes.el
+++ b/hibtypes.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 19-Sep-91 at 20:45:31
-;; Last-Mod: 14-Jun-22 at 20:06:40 by Mats Lidell
+;; Last-Mod: 17-Jul-22 at 23:19:27 by Bob Weiner
;;
;; Copyright (C) 1991-2022 Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
@@ -1357,7 +1357,7 @@ action type or a function symbol to call, i.e.
'<'actype-or-elisp-symbol
arg1 ... argN '>'. For example, <mail nil \"u...@somewhere.org\">."
(let* ((hbut:max-len 0)
(label-key-start-end (ibut:label-p nil action:start action:end t))
- (ibut-key (nth 0 label-key-start-end))
+ (lbl-key (nth 0 label-key-start-end))
(start-pos (nth 1 label-key-start-end))
(end-pos (nth 2 label-key-start-end))
actype actype-sym action args lbl var-flag)
@@ -1369,7 +1369,7 @@ arg1 ... argN '>'. For example, <mail nil
\"u...@somewhere.org\">."
;; and end-delim is either:
;; at the end of the buffer
;; or is followed by a space, punctuation or grouping character.
- (when (and ibut-key (or (null (char-before start-pos))
+ (when (and lbl-key (or (null (char-before start-pos))
(memq (char-syntax (char-before start-pos)) '(?\
?\> ?\( ?\))))
(not (memq (char-syntax (char-after (1+ start-pos))) '(?\
?\>)))
(or (null (char-after end-pos))
@@ -1377,7 +1377,7 @@ arg1 ... argN '>'. For example, <mail nil
\"u...@somewhere.org\">."
;; Some of these characters may have symbol-constituent
syntax
;; rather than punctuation, so check them individually.
(memq (char-after end-pos) '(?. ?, ?\; ?: ?! ?\' ?\"))))
- (setq lbl (ibut:key-to-label ibut-key))
+ (setq lbl (ibut:key-to-label lbl-key))
;; Handle $ preceding var name in cases where same name is
;; bound as a function symbol
(when (string-match "\\`\\$" lbl)
@@ -1395,21 +1395,33 @@ arg1 ... argN '>'. For example, <mail nil
\"u...@somewhere.org\">."
(special-form-p actype-sym))
actype-sym)))
(when actype
- (ibut:label-set lbl start-pos end-pos)
(setq action (read (concat "(" lbl ")"))
args (cdr action))
- (cond ((and (symbolp actype) (fboundp actype)
- (string-match "-p\\'" (symbol-name actype)))
- ;; Is a function with a boolean result
- (setq args `(',action)
- action `(display-boolean ',action)
- actype #'display-boolean))
- ((and (null args) (symbolp actype) (boundp actype)
- (or var-flag (not (fboundp actype))))
- ;; Is a variable, display its value as the action
- (setq args `(',actype)
- action `(display-variable ',actype)
- actype #'display-variable)))
+ (unless assist-flag
+ (cond ((and (symbolp actype) (fboundp actype)
+ (string-match "-p\\'" (symbol-name actype)))
+ ;; Is a function with a boolean result
+ (setq args `(',action)
+ action `(display-boolean ',action)
+ actype #'display-boolean))
+ ((and (null args) (symbolp actype) (boundp actype)
+ (or var-flag (not (fboundp actype))))
+ ;; Is a variable, display its value as the action
+ (setq args `(',actype)
+ action `(display-variable ',actype)
+ actype #'display-variable))
+ ((and (symbolp actype) (fboundp actype)
+ (string-match "\\b\\(get\\|value\\)" (symbol-name
actype)))
+ ;; For 'get' and 'value' functions, display the action
+ ;; result in the minibuffer
+ (setq args `(',action)
+ action `(display-value ',action)
+ actype #'display-value))))
+
+ ;; Create implicit button structure
+ (ibut:create :lbl-key lbl-key :lbl-start start-pos :lbl-end end-pos
+ :categ 'ibtypes::action :actype actype :args args :action
action)
+
;; Necessary so can return a null value, which actype:act cannot.
(let ((hrule:action
(if (eq hrule:action #'actype:identity)
@@ -1429,10 +1441,15 @@ If a boolean function or variable, display its value."
(when (hbut:is-p hbut)
(let* ((label (hbut:key-to-label (hattr:get hbut 'lbl-key)))
(actype (hattr:get hbut 'actype))
- (args (hattr:get hbut 'args)))
+ (args (hattr:get hbut 'args))
+ (type-help-func))
(setq actype (or (htype:def-symbol actype) actype))
(if hbut
- (progn (hbut:report hbut)
+ (progn (setq type-help-func (intern-soft (concat (symbol-name actype)
":help")))
+ (if (functionp type-help-func)
+ (funcall type-help-func hbut)
+ (let ((total (hbut:report hbut)))
+ (when total (hui:help-ebut-highlight))))
(when (memq actype '(display-boolean display-variable))
(apply #'actype:eval actype args)))
(error "(action:help): No action button labeled: %s" label)))))
