[nongnu] elpa/hyperdrive e0f7cee105 13/82: WIP: Add test-hyperdrive-org-link.el

[ELPA Syncer]

branch: elpa/hyperdrive
commit e0f7cee105fa15ad8d5e00cd2dea6519dbe03f19
Author: Adam Porter <adam@alphapapa.net>
Commit: Adam Porter <adam@alphapapa.net>

    WIP: Add test-hyperdrive-org-link.el
---
 DEV.org                           |   4 +-
 hyperdrive-org.el                 |   5 +
 tests/test-hyperdrive-org-link.el | 180 ++++++++++++++++++++++++++++
 tests/test-hyperdrive.el          | 238 +++++++++++++++++++-------------------
 4 files changed, 306 insertions(+), 121 deletions(-)

diff --git a/DEV.org b/DEV.org
index a402536259..0cb92a168d 100644
--- a/DEV.org
+++ b/DEV.org
@@ -283,8 +283,8 @@ How to tell which extension caused a peer-open or 
peer-remove event?
 
 ** Design
 
-+ Basically, we want to always store a full ~hyper://...~ URL when the user 
calls ~org-store-link~.
-+ Then, when the user calls ~org-insert-link~, we decide based on context (and 
maybe also on user input) what kind of a link to insert.
+1. Basically, we want to always store a full ~hyper://...~ URL when the user 
calls ~org-store-link~.
+2. Then, when the user calls ~org-insert-link~, we decide based on context 
(and maybe also on user input) what kind of a link to insert.
 
 *** Terminology
 
diff --git a/hyperdrive-org.el b/hyperdrive-org.el
index 4cca5bfc1b..2118e7a431 100644
--- a/hyperdrive-org.el
+++ b/hyperdrive-org.el
@@ -156,6 +156,11 @@ the current location."
         ;; FIXME: For fuzzy links, passing to hyperdrive-expand-url is a no-no.
         (hyperdrive-open-url (hyperdrive-expand-url (org-element-property 
:path context)))))))
 
+(defcustom hyperdrive-org-link-full-url nil
+  "Use full \"hyper://\" URLs when storing and inserting links in Org files.
+Otherwise, follow setting in `org-link-file-path-type'."
+  :type 'boolean)
+
 (defun hyperdrive--org-insert-link-after-advice (&rest _)
   "Modify just-inserted link as appropriate for `hyperdrive-mode' buffers."
   (when (and hyperdrive-mode hyperdrive-current-entry)
diff --git a/tests/test-hyperdrive-org-link.el 
b/tests/test-hyperdrive-org-link.el
new file mode 100644
index 0000000000..bbb22be1ea
--- /dev/null
+++ b/tests/test-hyperdrive-org-link.el
@@ -0,0 +1,180 @@
+;;; test-hyperdrive-org-link.el --- Tests for Hyperdrive.el  -*- 
lexical-binding: t; -*-
+
+;; Copyright (C) 2022 Joseph Turner <joseph@ushin.org>
+
+;; Author: Joseph Turner
+;; Author: Adam Porter <adam@alphapapa.net>
+;; Maintainer: Joseph Turner <joseph@ushin.org>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Affero General Public License
+;; as published by the Free Software Foundation; either version 3 of
+;; the License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public
+;; License along with this program. If not, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file tests Hyperdrive.el's Org link functionality.
+
+;;; Code:
+
+;;;; Requirements
+
+(require 'cl-lib)
+(require 'ert)
+(require 'pcase)
+
+(require 'with-simulated-input)
+
+(require 'hyperdrive)
+(require 'hyperdrive-org)
+
+(cl-defun hyperdrive-test-org-link-roundtrip
+    (contents &key store-from insert-into)
+  (declare (indent defun))
+  (let ((org-id-link-to-org-use-id nil)
+        (default-directory "/")
+        (org-link-file-path-type
+         (lambda (path)
+           (replace-regexp-in-string (rx bos (optional "file:")
+                                         "/hyper:/")
+                                     "hyper://" path)))
+        ;; (org-link-file-path-type
+        ;;  (lambda (path)
+        ;;    (string-trim-left (file-relative-name path)
+        ;;                      (rx "file:"))))
+        (store-from-entry (hyperdrive-entry-create
+                           :hyperdrive (hyperdrive-create :public-key (car 
store-from))
+                           :path (cdr store-from)))
+        (insert-into-entry (hyperdrive-entry-create
+                            :hyperdrive (hyperdrive-create :public-key (car 
insert-into))
+                            :path (cdr insert-into)))
+        org-stored-links)
+    (with-temp-buffer
+      (insert contents)
+      (org-mode)
+      (hyperdrive-mode)
+      (setq-local hyperdrive-current-entry store-from-entry)
+      (goto-char (point-min))
+      (re-search-forward (rx "<|>"))
+      (org-store-link nil 'interactive))
+    (with-temp-buffer
+      (org-mode)
+      (hyperdrive-mode)
+      (setq-local hyperdrive-current-entry insert-into-entry)
+      (with-simulated-input "RET"
+        (org-insert-link))
+      (buffer-substring-no-properties (point-min) (point-max)))))
+
+;; (while (re-search-forward (rx (0+ blank) (group (or "+" "-" "*")) (1+ 
blank)) nil t)
+;;   (replace-match (make-string (length (match-string 1)) ?\; )))
+
+
+
+;;;; Tests
+
+;; + Hyperdrive Org links :: Links to hyperdrive files/directories that are 
valid within Org documents.
+
+;;   - With protocol prefix
+
+;;     This link type or may not be surrounded by brackets. It may or may
+;;     not contain a search option. Path and search option must be
+;;     URL-encoded and separated by a decoded ~#~.
+
+;;     * No search option :: e.g. ~hyper://deadbeef/foo/bar%20quux.org~, which 
decodes to ~hyper://deadbeef/foo/bar quux.org~
+
+(cl-defmacro hyperdrive-test-org-link (name &key store-body store-from 
insert-into results)
+  "FIXME: Docstring."
+  (declare (indent defun))
+  (let ((test-name (make-symbol (concat "hyperdrive-test-org-link/" 
(symbol-name name))))
+        body-forms)
+    (pcase-dolist ((map (:let vars) (:result result)) results)
+      (push `(let (,@vars)
+               (should (equal (hyperdrive-test-org-link-roundtrip ,store-body
+                                :store-from ,store-from :insert-into 
,insert-into)
+                              ,result)))
+            body-forms))
+    `(ert-deftest ,test-name ()
+       ,@(nreverse body-forms))))
+
+(hyperdrive-test-org-link same-drive-same-file-before-heading
+  :store-body "<|>
+* Heading A
+:PROPERTIES:
+:CUSTOM_ID: example ID
+:END:
+* Heading B"
+  :store-from '("deadbeef" . "/foo/bar quux.org")
+  :insert-into '("deadbeef" . "/foo/bar quux.org")
+  :results (( :let ((org-link-file-path-type 'relative)
+                    (hyperdrive-org-link-full-url nil))
+              :result "[[./bar quux.org]]")
+            ( :let ((org-link-file-path-type 'relative)
+                    (hyperdrive-org-link-full-url t))
+              :result "[[hyper://deadbeef/foo/bar%20quux.org]]")
+
+            ( :let ((org-link-file-path-type 'absolute)
+                    (hyperdrive-org-link-full-url nil))
+              :result "[[/foo/bar quux.org]]")
+            ( :let ((org-link-file-path-type 'absolute)
+                    (hyperdrive-org-link-full-url t))
+              :result "[[hyper://deadbeef/foo/bar%20quux.org]]")
+
+            ( :let ((org-link-file-path-type 'noabbrev)
+                    (hyperdrive-org-link-full-url nil))
+              :result "[[/foo/bar quux.org]]")
+            ( :let ((org-link-file-path-type 'noabbrev)
+                    (hyperdrive-org-link-full-url t))
+              :result "[[hyper://deadbeef/foo/bar%20quux.org]]")
+            
+            ( :let ((org-link-file-path-type 'adaptive)
+                    (hyperdrive-org-link-full-url nil))
+              :result "[[./foo/bar quux.org]]")
+            ( :let ((org-link-file-path-type 'adaptive)
+                    (hyperdrive-org-link-full-url t))
+              :result "[[hyper://deadbeef/foo/bar%20quux.org]]")))
+
+;;     * ~CUSTOM_ID~ :: e.g.
+;;       ~hyper://deadbeef/foo/bar%20quux.org#%3A%3A%23baz%20zot~, which 
decodes to ~hyper://deadbeef/foo/bar quux.org#::#baz zot~
+
+;;     * Heading text search option :: With or without ~*~ (actually 
[[elisp:(rx "*" (0+ space))]]) prefix, e.g.
+
+;;       - ~hyper://deadbeef/foo/bar%20quux.org#%3A%3A%2AHeading%20A~, which 
decodes to ~hyper://deadbeef/foo/bar quux.org#::*Heading A~
+;;       - ~hyper://deadbeef/foo/bar%20quux.org#%3A%3A%2A%20%20Heading%20A~, 
which decodes to ~hyper://deadbeef/foo/bar quux.org#::*  Heading A~
+;;       - ~hyper://deadbeef/foo/bar%20quux.org#%3A%3AHeading%20A~, which 
decodes to ~hyper://deadbeef/foo/bar quux.org#::Heading A~
+
+;;   - Without protocol prefix
+
+;;     This link type must be surrounded by brackets.  It has no
+;;     URL-encoding in any part. It may or may not contain a path:
+
+;;     + With path :: A link pointing to a file at a path, starting with ~/~ 
or ~.~, with or without search option:
+
+;;       - No search option :: ~[[/foo/bar quux.org]]~
+
+;;       - ~CUSTOM_ID~ :: e.g. ~[[/foo/bar quux.org::#CUSTOM_ID]]~
+
+;;       - Heading text search option :: With or without ~*~ (actually 
[[elisp:(rx "*" (0+ space))]]) prefix, e.g.
+
+;;         + ~[[/foo/bar quux.org::*Heading A]]~
+;;         + ~[[/foo/bar quux.org::*  Heading A]]~
+;;         + ~[[/foo/bar quux.org::Heading A]]~
+
+;;     + Without path :: A link pointing to a heading in the same file with 
search option alone:
+
+;;       - ~CUSTOM_ID~ :: e.g. ~#CUSTOM_ID~
+
+;;       - Heading text search option :: With or without ~*~ (actually 
[[elisp:(rx "*" (0+ space))]]) prefix, e.g.
+
+;;         + ~*Heading A~
+;;         + ~*  Heading A~
+;;         + ~Heading A~
+
diff --git a/tests/test-hyperdrive.el b/tests/test-hyperdrive.el
index 6a38fa1993..d8b4d3862a 100644
--- a/tests/test-hyperdrive.el
+++ b/tests/test-hyperdrive.el
@@ -182,130 +182,130 @@ LINK is an Org link as a string."
 
 ;;;;; Inserting links
 
-(cl-defun hyperdrive-test-org-link-roundtrip
-    (contents &key store-from insert-into)
-  (let ((org-id-link-to-org-use-id nil)
-        (default-directory "/")
-        (org-link-file-path-type
-         (lambda (path)
-           (replace-regexp-in-string (rx bos (optional "file:")
-                                         "/hyper:/")
-                                     "hyper://" path)))
-        ;; (org-link-file-path-type
-        ;;  (lambda (path)
-        ;;    (string-trim-left (file-relative-name path)
-        ;;                      (rx "file:"))))
-        (store-from-entry (hyperdrive-entry-create
-                           :hyperdrive (hyperdrive-create :public-key (car 
store-from))
-                           :path (cdr store-from)))
-        (insert-into-entry (hyperdrive-entry-create
-                            :hyperdrive (hyperdrive-create :public-key (car 
insert-into))
-                            :path (cdr insert-into)))
-        org-stored-links)
-    (with-temp-buffer
-      (insert contents)
-      (org-mode)
-      (hyperdrive-mode)
-      (setq-local hyperdrive-current-entry store-from-entry)
-      (goto-char (point-min))
-      (re-search-forward (rx "<|>"))
-      (org-store-link nil 'interactive))
-    (with-temp-buffer
-      (org-mode)
-      (hyperdrive-mode)
-      (setq-local hyperdrive-current-entry insert-into-entry)
-      (with-simulated-input "RET"
-        (org-insert-link))
-      (buffer-substring-no-properties (point-min) (point-max)))))
-
-;;;;;; Test cases
-
-(ert-deftest 
hyperdrive-link-no-protocol-no-path-same-drive-same-file-custom-id ()
-  (should
-   (equal "[[#example ID]]"
-          (hyperdrive-test-org-link-roundtrip
-           "
-* Heading A
-:PROPERTIES:
-:CUSTOM_ID: example ID
-:END:
-<|>
-* Heading B"
-           :store-from '("deadbeef" . "/foo/bar.org")
-           :insert-into '("deadbeef" . "/foo/bar.org")))))
-
-(ert-deftest hyperdrive-link-same-drive-different-file-before-heading ()
-  "Linking to a file (before the first heading) and on same drive."
-  (should
-   (equal "[[/foo/bar.org]]"
-          (hyperdrive-test-org-link-roundtrip
-           "<|>
-* Heading A
-* Heading B"
-           :store-from '("deadbeef" . "/foo/bar.org")
-           :insert-into '("deadbeef" . "/foo/zot.org")))))
-
-(ert-deftest hyperdrive-link-same-drive-same-file-in-heading-without-custom-id 
()
-  "Linking to a heading within the same file (and on same drive)."
-  (should
-   (equal "[[*Heading A]]"
-          (hyperdrive-test-org-link-roundtrip
-           "* Heading A
-<|>
-* Heading B"
-           :store-from '("deadbeef" . "/foo/bar.org")
-           :insert-into '("deadbeef" . "/foo/bar.org")))))
-
-(ert-deftest hyperdrive-link-heading-within-drive ()
-  "Linking to a heading within the same drive but different file.")
-
-;;;;;;; With protocol
-
-;; These links will look the same regardless of hyperdrive or path.
-
-(ert-deftest hyperdrive-link-different-drive-with-custom-id ()
-  (should
-   (equal "[[hyper://deadbeef/foo/bar.org#%3A%3A%23example%20ID]]"
-          (hyperdrive-test-org-link-roundtrip
-           "
-* Heading A
-:PROPERTIES:
-:CUSTOM_ID: example ID
-:END:
-<|>
-* Heading B"
-           :store-from '("deadbeef" . "/foo/bar.org")
-           :insert-into '("fredbeef" . "/foo/bar.org")))))
-
-;; (hyperdrive-test-org-link-roundtrip
-;;  "<|>
+;; (cl-defun hyperdrive-test-org-link-roundtrip
+;;     (contents &key store-from insert-into)
+;;   (let ((org-id-link-to-org-use-id nil)
+;;         (default-directory "/")
+;;         (org-link-file-path-type
+;;          (lambda (path)
+;;            (replace-regexp-in-string (rx bos (optional "file:")
+;;                                          "/hyper:/")
+;;                                      "hyper://" path)))
+;;         ;; (org-link-file-path-type
+;;         ;;  (lambda (path)
+;;         ;;    (string-trim-left (file-relative-name path)
+;;         ;;                      (rx "file:"))))
+;;         (store-from-entry (hyperdrive-entry-create
+;;                            :hyperdrive (hyperdrive-create :public-key (car 
store-from))
+;;                            :path (cdr store-from)))
+;;         (insert-into-entry (hyperdrive-entry-create
+;;                             :hyperdrive (hyperdrive-create :public-key (car 
insert-into))
+;;                             :path (cdr insert-into)))
+;;         org-stored-links)
+;;     (with-temp-buffer
+;;       (insert contents)
+;;       (org-mode)
+;;       (hyperdrive-mode)
+;;       (setq-local hyperdrive-current-entry store-from-entry)
+;;       (goto-char (point-min))
+;;       (re-search-forward (rx "<|>"))
+;;       (org-store-link nil 'interactive))
+;;     (with-temp-buffer
+;;       (org-mode)
+;;       (hyperdrive-mode)
+;;       (setq-local hyperdrive-current-entry insert-into-entry)
+;;       (with-simulated-input "RET"
+;;         (org-insert-link))
+;;       (buffer-substring-no-properties (point-min) (point-max)))))
+
+;; ;;;;;; Test cases
+
+;; (ert-deftest 
hyperdrive-link-no-protocol-no-path-same-drive-same-file-custom-id ()
+;;   (should
+;;    (equal "[[#example ID]]"
+;;           (hyperdrive-test-org-link-roundtrip
+;;            "
 ;; * Heading A
-;; * Heading B")
-;; "[[hyper://public-key/foo/bar]]"
-
-;; (hyperdrive-test-org-link-roundtrip
-;;  "* Heading A
-;; <|>
-;; * Heading B")
-;; "[[hyper://public-key/foo/bar#Heading%20A][Heading A]]"
-
-;; (hyperdrive-test-org-link-roundtrip
-;;  "* Heading A
 ;; :PROPERTIES:
-;; :ID: deadbeef
+;; :CUSTOM_ID: example ID
 ;; :END:
 ;; <|>
-;; * Heading B")
-;; "[[hyper://public-key/foo/bar#deadbeef][Heading A]]"
+;; * Heading B"
+;;            :store-from '("deadbeef" . "/foo/bar.org")
+;;            :insert-into '("deadbeef" . "/foo/bar.org")))))
+
+;; (ert-deftest hyperdrive-link-same-drive-different-file-before-heading ()
+;;   "Linking to a file (before the first heading) and on same drive."
+;;   (should
+;;    (equal "[[/foo/bar.org]]"
+;;           (hyperdrive-test-org-link-roundtrip
+;;            "<|>
+;; * Heading A
+;; * Heading B"
+;;            :store-from '("deadbeef" . "/foo/bar.org")
+;;            :insert-into '("deadbeef" . "/foo/zot.org")))))
+
+;; (ert-deftest 
hyperdrive-link-same-drive-same-file-in-heading-without-custom-id ()
+;;   "Linking to a heading within the same file (and on same drive)."
+;;   (should
+;;    (equal "[[*Heading A]]"
+;;           (hyperdrive-test-org-link-roundtrip
+;;            "* Heading A
+;; <|>
+;; * Heading B"
+;;            :store-from '("deadbeef" . "/foo/bar.org")
+;;            :insert-into '("deadbeef" . "/foo/bar.org")))))
+
+;; (ert-deftest hyperdrive-link-heading-within-drive ()
+;;   "Linking to a heading within the same drive but different file.")
+
+;; ;;;;;;; With protocol
 
-;; (hyperdrive-test-org-link-roundtrip
-;;  "* Heading A
+;; ;; These links will look the same regardless of hyperdrive or path.
+
+;; (ert-deftest hyperdrive-link-different-drive-with-custom-id ()
+;;   (should
+;;    (equal "[[hyper://deadbeef/foo/bar.org#%3A%3A%23example%20ID]]"
+;;           (hyperdrive-test-org-link-roundtrip
+;;            "
+;; * Heading A
 ;; :PROPERTIES:
-;; :CUSTOM_ID: custom-id
+;; :CUSTOM_ID: example ID
 ;; :END:
 ;; <|>
-;; * Heading B")
-;; "[[hyper://public-key/foo/bar#custom-id][Heading A]]"
-
-
-;; "hyper://public-key/foo/bar#deadbeef"
+;; * Heading B"
+;;            :store-from '("deadbeef" . "/foo/bar.org")
+;;            :insert-into '("fredbeef" . "/foo/bar.org")))))
+
+;; ;; (hyperdrive-test-org-link-roundtrip
+;; ;;  "<|>
+;; ;; * Heading A
+;; ;; * Heading B")
+;; ;; "[[hyper://public-key/foo/bar]]"
+
+;; ;; (hyperdrive-test-org-link-roundtrip
+;; ;;  "* Heading A
+;; ;; <|>
+;; ;; * Heading B")
+;; ;; "[[hyper://public-key/foo/bar#Heading%20A][Heading A]]"
+
+;; ;; (hyperdrive-test-org-link-roundtrip
+;; ;;  "* Heading A
+;; ;; :PROPERTIES:
+;; ;; :ID: deadbeef
+;; ;; :END:
+;; ;; <|>
+;; ;; * Heading B")
+;; ;; "[[hyper://public-key/foo/bar#deadbeef][Heading A]]"
+
+;; ;; (hyperdrive-test-org-link-roundtrip
+;; ;;  "* Heading A
+;; ;; :PROPERTIES:
+;; ;; :CUSTOM_ID: custom-id
+;; ;; :END:
+;; ;; <|>
+;; ;; * Heading B")
+;; ;; "[[hyper://public-key/foo/bar#custom-id][Heading A]]"
+
+
+;; ;; "hyper://public-key/foo/bar#deadbeef"