[elpa] scratch/hyperbole-lexbind af55195 05/20: Make Action Key handle bi-directional jumping for Org mode radio target and internal links

[Stefan Monnier]

branch: scratch/hyperbole-lexbind
commit af55195f78cee511bf4dd376053270beffda33c3
Author: Bob Weiner <address@hidden>
Commit: Bob Weiner <address@hidden>

    Make Action Key handle bi-directional jumping for Org mode radio target and 
internal links
---
 hsys-org.el | 173 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 163 insertions(+), 10 deletions(-)

diff --git a/hsys-org.el b/hsys-org.el
index 59a1eb1..c36c424 100644
--- a/hsys-org.el
+++ b/hsys-org.el
@@ -48,11 +48,16 @@
 (defib org-mode ()
   "Follows any Org mode link at point or cycles through views of the outline 
subtree at point."
   (when (derived-mode-p 'org-mode)
-    (cond ((org-link-at-p)
-          (hact 'org-link nil))
+    (cond ((org-internal-link-target-at-p)
+          (hact 'org-internal-link-target))
+         ((org-radio-target-def-at-p)
+          (hact 'org-radio-target))
+         ((org-link-at-p)
+          (hact 'org-link))
          ((org-at-heading-p)
           (hact 'hsys-org-cycle))
-         (t (hact 'org-meta-return)))))
+         (t
+          (hact 'org-meta-return)))))
 
 (defun org-mode:help (&optional _but)
   "If on an Org mode heading, cycles through views of the whole buffer outline.
@@ -65,22 +70,170 @@ If on an Org mode link, displays standard Hyperbole help."
           (hact 'hsys-org-global-cycle)
           t))))
 
-(defact org-link (link)
-  "Follows an Org mode LINK.  If LINK is nil, follows the link at point."
+(defact org-link (&optional link)
+  "Follows an optional Org mode LINK to its target.
+If LINK is nil, follows any link at point.  Otherwise, triggers an error."
   (if (stringp link)
       (org-open-link-from-string link) ;; autoloaded
-    (org-open-at-point-global))) ;; autoloaded
+    (org-open-at-point))) ;; autoloaded
+
+(defact org-internal-link-target (&optional link-target)
+  "Follows an optional Org mode LINK-TARGET back to its link definition.
+If LINK-TARGET is nil, follows any link target at point.  Otherwise, triggers 
an error."
+  (let (start-end)
+    (cond ((stringp link-target)
+          (setq start-end t)
+          (org-search-internal-link-p link-target))
+         ((null link-target)
+          (when (setq start-end (org-internal-link-target-at-p))
+            (org-search-internal-link-p (buffer-substring-no-properties
+                                         (car start-end) (cdr start-end))))))
+    (unless start-end
+      (error "(org-internal-link-target): Point must be on a link target (not 
the link itself)"))))
+
+
+(defact org-radio-target (&optional target)
+  "Jumps to the next occurrence of an optional Org mode radio TARGET link.
+If TARGET is nil and point is on a radio target definition or link, it
+uses that one.  Otherwise, triggers an error."
+  (let (start-end)
+    (cond ((stringp target)
+          (setq start-end t)
+          (org-to-next-radio-target-link target))
+         ((null target)
+          (when (setq start-end (org-radio-target-at-p))
+            (org-to-next-radio-target-link (buffer-substring-no-properties
+                                            (car start-end) (cdr 
start-end))))))
+    (unless start-end
+      (error "(org-radio-target): Point must be on a radio target definition 
or link"))))
 
 ;;; ************************************************************************
 ;;; Public functions
 ;;; ************************************************************************
 
+(defun org-region-with-text-property-value (pos property)
+  "Returns (start . end) buffer positions of the region around POS that shares 
its non-nil text PROPERTY value, else nil."
+  (if (null pos) (setq pos (point)))
+  (let ((property-value (get-text-property pos property))
+       (start-point pos))
+    (when property-value
+       ;; Can't use previous-single-property-change here because it
+       ;; ignores characters that lack the property, i.e. have nil values.
+       (if (bobp)
+           (setq start-point (point-min))
+         (while (equal (get-text-property (1- start-point) property) 
property-value)
+           (setq start-point (1- start-point))))
+       (cons start-point (next-single-property-change start-point property)))))
+
+(defsubst org-link-at-p ()
+  "Returns non-nil iff point is on an Org mode link.
+Assumes caller has already checked that the current buffer is in org-mode."
+  (org-face-at-p 'org-link))
+
 ;; Assumes caller has already checked that the current buffer is in org-mode.
-(defun org-link-at-p ()
-  "Returns non-nil iff point is on an Org mode link."
+(defsubst org-target-at-p ()
+  "Returns non-nil iff point is on an Org mode radio target (definition) or 
link target (referent).
+Assumes caller has already checked that the current buffer is in org-mode."
+  (org-face-at-p 'org-target))
+
+(defun org-radio-target-link-at-p ()
+  "Returns (target-start . target-end) positions iff point is on an Org mode 
radio target link (referent), else nil."
+  (and (get-text-property (point) 'org-linked-text)
+       (org-link-at-p)
+       (org-region-with-text-property-value (point) 'org-linked-text)))
+
+(defun org-radio-target-def-at-p ()
+  "Returns (target-start . target-end) positions iff point is on an Org mode 
radio target (definition), including any delimiter characters, else nil."
+  (when (org-target-at-p)
+    (save-excursion
+      (if (not (looking-at "<<<"))
+         (goto-char (or (previous-single-property-change (point) 'face) 
(point-min))))
+      (if (looking-at "<<<")
+         (goto-char (match-end 0)))
+      (and (get-text-property (point) 'org-linked-text)
+          (org-region-with-text-property-value (point) 'face)))))
+
+(defun org-radio-target-at-p ()
+  "Returns (target-start . target-end) positions iff point is on an Org mode 
<<<radio target definition>>> or radio target link (referent), including any 
delimiter characters, else nil."
+  (or (org-radio-target-def-at-p)
+      (org-radio-target-link-at-p)))
+
+(defun org-internal-link-target-at-p ()
+  "Returns (target-start . target-end) positions iff point is on an Org mode 
<<link target>>, including any delimiter characters, else nil."
+  (when (org-target-at-p)
+    (save-excursion
+      (if (not (looking-at "<<"))
+         (goto-char (or (previous-single-property-change (point) 'face) 
(point-min))))
+      (if (looking-at "<<<?")
+         (goto-char (match-end 0)))
+      (and (not (get-text-property (point) 'org-linked-text))
+          (org-region-with-text-property-value (point) 'face)))))
+
+(defun org-face-at-p (org-face-type)
+  "Returns `org-face-type` iff point is on a character with face 
`org-face-type', a symbol, else nil."
   (let ((face-prop (get-text-property (point) 'face)))
-    (or (eq face-prop 'org-link)
-       (and (listp face-prop) (memq 'org-link face-prop)))))
+    (when (or (eq face-prop org-face-type)
+             (and (listp face-prop) (memq org-face-type face-prop)))
+      org-face-type)))
+
+(defun org-search-internal-link-p (target)
+  "Searches from buffer start for an Org internal link definition matching 
TARGET.
+White spaces are insignificant.  Returns t if a link is found, else nil."
+  (if (string-match "<<.+>>" target)
+      (setq target (substring target 2 -2)))
+  (let ((re (format "%s"
+                   (mapconcat #'regexp-quote
+                              (split-string target)
+                              "[ \t]+\\(?:\n[ \t]*\\)?")))
+       (origin (point)))
+    (goto-char (point-min))
+    (catch :link-match
+      (while (re-search-forward re nil t)
+       (backward-char)
+       (let ((object (org-element-context)))
+         (when (eq (org-element-type object) 'link)
+           (org-show-context 'link-search)
+           (throw :link-match t))))
+      (goto-char origin)
+      nil)))
+
+(defun org-search-radio-target-link-p (target)
+  "Searches from point for a radio target link matching TARGET.
+White spaces are insignificant.  Returns t if a target link is found, else 
nil."
+  (if (string-match "<<<.+>>>" target)
+      (setq target (substring target 3 -3)))
+  (let ((re (format "%s"
+                   (mapconcat #'regexp-quote
+                              (split-string target)
+                              "[ \t]+\\(?:\n[ \t]*\\)?")))
+       (origin (point)))
+    (catch :radio-match
+      (while (re-search-forward re nil t)
+       (backward-char)
+       (let ((object (org-element-context)))
+         (when (eq (org-element-type object) 'link)
+           (org-show-context 'link-search)
+           (throw :radio-match t))))
+      (goto-char origin)
+      nil)))
+
+(defun org-to-next-radio-target-link (target)
+  "Moves to the start of the next radio TARGET link if found.  TARGET must be 
a string."
+  (if (string-match "<<<.+>>>" target)
+      (setq target (substring target 3 -3)))
+  (let ((opoint (point))
+       (start-end (org-radio-target-at-p))
+       found)
+    (if start-end
+       ;; Move past any current target link
+       (goto-char (cdr start-end)))
+    (while (and (org-search-radio-target-link-p target)
+               (setq found t)
+               (not (org-radio-target-link-at-p))))
+    (when found
+      (if (org-radio-target-link-at-p)
+         (goto-char (or (previous-single-property-change (point) 'face) 
(point-min)))
+       (goto-char opoint)))))
 
 ;;; ************************************************************************
 ;;; Private functions