branch: externals/hyperbole
commit dbc6f353604876721b49a8382651b56df7d67a1c
Author: Bob Weiner <r...@gnu.org>
Commit: Bob Weiner <r...@gnu.org>
Add initial version of "hywiki.el" and the hywiki ibtype
---
ChangeLog | 21 +++
MANIFEST | 4 +
Makefile | 7 +-
hasht.el | 432 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
hibtypes.el | 9 +-
hsys-org.el | 21 ++-
hui-em-but.el | 63 ++++++---
hywiki.el | 433 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8 files changed, 963 insertions(+), 27 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index e03a662e7d..9d7fd5ef74 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,24 @@
+2024-04-22 Bob Weiner <r...@gnu.org>
+
+* hywiki.el: Add new auto-wikiword note-taking system with `hywiki' ibtype.
+ hasht.el: Temporarily add this for hywiki hash table support.
+ hibtypes.el (load "hywiki"): Add at lowest ibtype priority.
+ hsys-org.el (hsys-org-link-at-p): Support HyWiki word handling.
+ Makefile (EL_COMPILE):
+ MANIFEST: Add hywiki.el and hasht.el.
+
+* hui-em-but.el (hproperty:but-start, hproperty:but-end, hproperty:but-delete):
+ Add these functions and use in hywiki.el.
+
+2024-04-21 Bob Weiner <r...@gnu.org>
+
+* hui-em-but.el (hproperty:but-clear): Add optional args 'property' and
'value'.
+ When 'property' is given, clear the button only when property's value
+ matches 'value'.
+ (hproperty:but-p, hproperty:but-get): Add optional args
+ 'property' and 'value', matching only when 'property' equals 'value', if
+ given.
+
2024-04-20 Bob Weiner <r...@gnu.org>
* hui-select.el (hui-c++-defun-prompt-regexp): Add to eliminate an Emacs
diff --git a/MANIFEST b/MANIFEST
index 3fc33c06fa..f40aa462e9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -73,6 +73,10 @@ hsmail.el - GNU Hyperbole buttons in mail
composer: mail
kotl/MANIFEST - Summary of Koutliner files
kotl/EXAMPLE.kotl - Sample Koutline document explaining Koutliner features
+* --- HYPERBOLE NOTES ---
+hywiki.el - Hyperbole's auto-wikiword note-taking system
+hasht.el - Create hash tables from lists and operate on them.
+
* --- HYPERBOLE ROLO ---
hyrolo.el - Hierarchical, multi-file, easy-to-use record management
system
hyrolo.py - Output file header and matching entries from HyRolo
files via the command-line
diff --git a/Makefile b/Makefile
index 940d0100d1..8a0a4fd8e6 100644
--- a/Makefile
+++ b/Makefile
@@ -3,7 +3,7 @@
# Author: Bob Weiner
#
# Orig-Date: 15-Jun-94 at 03:42:38
-# Last-Mod: 14-Apr-24 at 23:00:20 by Bob Weiner
+# Last-Mod: 22-Apr-24 at 02:10:20 by Bob Weiner
#
# Copyright (C) 1994-2023 Free Software Foundation, Inc.
# See the file HY-COPY for license information.
@@ -190,8 +190,9 @@ EL_COMPILE = hact.el hactypes.el hargs.el hbdata.el
hbmap.el hbut.el \
hsys-org-roam.el hsys-www.el hsys-xref.el hsys-youtube.el htz.el \
hycontrol.el hui-jmenu.el hui-menu.el hui-mini.el hui-mouse.el
hui-select.el \
hui-treemacs.el hui-window.el hui.el hvar.el hversion.el hypb.el
hyperbole.el \
- hyrolo-demo.el hyrolo-logic.el hyrolo-menu.el hyrolo.el
hywconfig.el set.el hypb-ert.el \
- hui-dired-sidebar.el hypb-maintenance.el hui-em-but.el
hui-register.el
+ hyrolo-demo.el hyrolo-logic.el hyrolo-menu.el hyrolo.el
hywconfig.el hywiki.el \
+ hasht.el set.el hypb-ert.el hui-dired-sidebar.el
hypb-maintenance.el hui-em-but.el \
+ hui-register.el
EL_SRC = $(EL_COMPILE)
diff --git a/hasht.el b/hasht.el
new file mode 100644
index 0000000000..17d0c5e51f
--- /dev/null
+++ b/hasht.el
@@ -0,0 +1,432 @@
+;;!emacs
+;;
+;; FILE: hasht.el
+;; SUMMARY: Create hash tables from lists and operate on them.
+;; USAGE: GNU Emacs Lisp Library
+;; KEYWORDS: extensions, tools
+;;
+;; AUTHOR: Bob Weiner
+;;
+;; ORIG-DATE: 16-Mar-90 at 03:38:48
+;; LAST-MOD: 30-Jul-16 at 08:50:38 by Bob Weiner
+;;
+;; Copyright (C) 1990-1995, 1997, 2016 Free Software Foundation, Inc.
+;; See the file BR-COPY for license information.
+;;
+;; This file is part of the OO-Browser.
+
+;; The OO-Browser is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; The OO-Browser 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with the OO-Browser. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Featureful set of hash table operators for use in personal programs.
+;;
+;; `hash-make' creates a hash table from an association list, `hash-add'
+;; adds a value-key pair to a hash table, and `hash-lookup' finds the value
+;; associated with a given key in a hash table, if any.
+;;
+;; `hash-map' does the same thing as `mapcar' but operates on hash tables
+;; instead.
+;;
+;; For a list of 300 items, these hash tables improve lookup times by a
+;; factor of between 8 and 10 to 1 over those for an unsorted list.
+;;
+;; Public and private function names are alphabetized for easy location.
+
+;;; Code:
+;;; ************************************************************************
+;;; Public variables
+;;; ************************************************************************
+
+(defvar hash-merge-values-function 'hash-merge-values
+ "*Function to call in hash-merge to merge the values from 2 hash tables that
contain the same key.
+It is sent the two values as arguments.")
+
+;;; ************************************************************************
+;;; Public functions
+;;; ************************************************************************
+
+(defun hash-add (value key hash-table)
+ "Add VALUE, any lisp object, referenced by KEY, a string, to HASH-TABLE.
+Replaces any VALUE previously referenced by KEY."
+ (if (hashp hash-table)
+ (let* ((obarray (hash-obarray hash-table))
+ (sym (intern key obarray)))
+ (if sym (set sym value)))))
+
+(defun hash-copy (hash-table)
+ "Return a copy of HASH-TABLE, list and vector elements are shared across
both tables."
+ (if (not (hashp hash-table))
+ (error "(hash-copy): Invalid hash-table: `%s'" hash-table))
+ (let ((htable-copy (hash-make (length (hash-obarray hash-table)))))
+ (hash-map
+ (lambda (elt) (hash-add (car elt) (cdr elt) htable-copy))
+ hash-table)
+ htable-copy))
+
+(defun hash-count (hash-table)
+ "Return number of elements stored in HASH-TABLE or nil if not a valid hash
table."
+ (if (hashp hash-table)
+ (let ((obarray (hash-obarray hash-table))
+ (count 0))
+ (mapatoms (lambda (sym)
+ (and (boundp sym) sym (setq count (1+ count))))
+ obarray)
+ count)))
+
+(defun hash-delete (key hash-table)
+ "Delete element referenced by KEY, a string, from HASH-TABLE.
+Return nil if KEY is not in HASH-TABLE or non-nil otherwise."
+ (if (hashp hash-table)
+ (let* ((obarray (hash-obarray hash-table))
+ (sym (intern-soft key obarray)))
+ (if sym
+ (progn (makunbound sym)
+ (unintern sym nil))))))
+
+(defun hash-deep-copy (obj)
+ "Return a copy of OBJ with new copies of all elements, except symbols."
+ (cond ((null obj) nil)
+ ((stringp obj)
+ (copy-sequence obj))
+ ((hashp obj)
+ (let ((htable-copy (hash-make (length (hash-obarray obj)))))
+ (mapc
+ (lambda (elt) (hash-add (car elt) (cdr elt) htable-copy))
+ (hash-map 'hash-deep-copy obj))
+ htable-copy))
+ ((vectorp obj)
+ ;; convert to list for mapping
+ (setq obj (append obj nil))
+ ;; Return as a vector
+ (vconcat (mapcar 'hash-deep-copy obj)))
+ ((atom obj) obj)
+ ((nlistp obj)
+ (error "(hash-deep-copy): Invalid type, `%s'" obj))
+ (t ;; list
+ (cons (hash-deep-copy (car obj)) (hash-deep-copy (cdr obj))))))
+
+(defun hash-empty-p (hash-table)
+ "Return t if HASH-TABLE is empty, else nil."
+ (and (hashp hash-table) (equal hash-table hash-empty-htable)))
+
+(defalias 'hash-get 'hash-lookup)
+
+(defun hash-key-p (key hash-table)
+ "Return non-nil iff KEY is in HASH-TABLE. KEY's hash table symbol is
returned."
+ (if (hashp hash-table)
+ (let* ((obarray (hash-obarray hash-table))
+ (sym (intern-soft key obarray)))
+ (if (boundp sym) sym))))
+
+(defun hash-lookup (key hash-table)
+ "Lookup KEY in HASH-TABLE and return associated value.
+If value is nil, this function does not tell you whether or not KEY is in the
+hash table. Use `hash-key-p' instead for that function."
+ (if (hashp hash-table)
+ (let* ((obarray (hash-obarray hash-table))
+ (sym (intern-soft key obarray)))
+ (if (boundp sym) (symbol-value sym)))))
+
+(defun hash-make (initializer &optional reverse)
+ "Create a hash table from INITIALIZER.
+INITIALIZER may be an alist with elements of the form (<value> . <key>) from
+which the hash table is built. Alternatively, it may be a non-negative
+integer which is used as the minimum size of a new, empty hash table.
+Optional non-nil second argument REVERSE means INITIALIZER has elements of
+form (<key> . <value>)."
+ (cond ((integerp initializer)
+ (if (>= initializer 0)
+ (cons 'hasht (make-vector (hash-next-prime initializer) 0))
+ (error "(hash-make): Initializer must be >= 0, not `%s'"
+ initializer)))
+ ((numberp initializer)
+ (error "(hash-make): Initializer must be a positive integer, not `%f'"
+ initializer))
+ (t (let* ((vlen (hash-next-prime (length initializer)))
+ (obarray (make-vector vlen 0))
+ key value sym)
+ (mapc
+ (lambda (cns)
+ (if (consp cns)
+ (if reverse
+ (setq key (car cns) value (cdr cns))
+ (setq key (cdr cns) value (car cns))))
+ (if (setq sym (intern key))
+ (set sym value)))
+ initializer)
+ (cons 'hasht obarray)))))
+
+(defun hash-make-prepend (initializer &optional reverse)
+ "Create a hash table from INITIALIZER.
+INITIALIZER may be an alist with elements of the form (<value> . <key>) from
+which the hash table is built. Optional non-nil second argument REVERSE
+means INITIALIZER has elements of form (<key> . <value>).
+
+The resultant value associated with a <key> is a list of all of the <values>
+given in INITIALIZER entries which contain the <key>. The values are listed
+in reverse order of occurrence (they are prepended to the list)."
+ (let* ((vlen (hash-next-prime (length initializer)))
+ (obarray (make-vector vlen 0))
+ key value sym)
+ (mapc
+ (lambda (cns)
+ (if (consp cns)
+ (if reverse
+ (setq key (car cns) value (cdr cns))
+ (setq key (cdr cns) value (car cns))))
+ (setq sym (intern key))
+ (if (boundp sym)
+ (set sym (cons value (symbol-value sym)))
+ (set sym (cons value nil))))
+ initializer)
+ (cons 'hasht obarray)))
+
+(defun hash-map (func hash-table)
+ "Return a list of the results of applying FUNC to each (<value> . <key>)
element of HASH-TABLE."
+ (if (not (hashp hash-table))
+ (error "(hash-map): Invalid hash-table: `%s'" hash-table))
+ (let ((result))
+ (mapatoms (lambda (sym)
+ (and (boundp sym)
+ sym
+ (setq result (cons (funcall
+ func
+ (cons (symbol-value sym)
+ (symbol-name sym)))
+ result))))
+ (hash-obarray hash-table))
+ result))
+
+(defun hash-merge (&rest hash-tables)
+ "Merge any number of HASH-TABLES. Return resultant hash table.
+A single argument consisting of a list of hash tables may also be given.
+Return an empty hash table if any argument from the merge list is other
+than nil or a hash table.
+
+Use the value of `hash-merge-values-function' to merge the values of entries
+whose keys are the same."
+ (let ((empty-ht (hash-make 1)))
+ (and (not (hashp (car hash-tables)))
+ (listp (car hash-tables))
+ ;; Handle situation where a list of hash-tables is passed in as a
+ ;; single argument, rather than as multiple arguments.
+ (setq hash-tables (car hash-tables)))
+ (if (memq nil (mapcar (lambda (ht) (or (null ht) (hashp ht)))
+ hash-tables))
+ empty-ht
+ (setq hash-tables
+ (delq nil (mapcar (lambda (ht)
+ (if (hash-empty-p ht) nil ht))
+ hash-tables)))
+ (let ((len (length hash-tables)))
+ (cond ((= len 0) empty-ht)
+ ((= len 1) (car hash-tables))
+ ;; Make the merged hash-table be 20% larger than the number of
+ ;; entries filled in all hash-tables to be merged, so that
+ ;; hash misses are minimized.
+ (t (let ((htable (hash-make
+ (ceiling
+ (* 1.2 (apply '+ (mapcar 'hash-count
+ hash-tables))))))
+ key value)
+ (mapc
+ (lambda (ht)
+ (hash-map (lambda (val-key-cons)
+ (setq value (car val-key-cons)
+ key (cdr val-key-cons))
+ (if (not (hash-key-p key htable))
+ (hash-add value key htable)
+ ;; Merge values
+ (hash-add
+ (funcall hash-merge-values-function
+ (hash-get key htable)
+ value)
+ key htable)))
+ ht))
+ hash-tables)
+ htable)))))))
+
+(defun hash-merge-first-value (value1 value2)
+ "Return a copy of VALUE1 for use in a hash table merge.
+
+This is suitable for use as a value of `hash-merge-values-function'."
+ ;; Copy list so that merged result does not share structure with the
+ ;; hash tables being merged.
+ (if (listp value1) (copy-sequence value1) value1))
+
+(defun hash-merge-values (value1 value2)
+ "Return a list from merging VALUE1 and VALUE2 or creating a new list.
+Nil values are thrown away. If both arguments are lists, their elements are
+assumed to be strings and the result is a set of ordered strings.
+
+This is suitable for use as a value of `hash-merge-values-function'."
+ ;; Copy lists so that merged result does not share structure with the
+ ;; hash tables being merged.
+ (if (listp value1) (setq value1 (copy-sequence value1)))
+ (if (listp value2) (setq value2 (copy-sequence value2)))
+ (cond ((and (listp value1) (listp value2))
+ ;; Assume desired result is a set of strings.
+ (hash-set-of-strings (sort (append value1 value2) 'string-lessp)))
+ ((null value1)
+ value2)
+ ((null value2)
+ value1)
+ ((listp value1)
+ (cons value2 value1))
+ ((listp value2)
+ (cons value1 value2))
+ (t (list value1 value2))))
+
+(make-obsolete 'hash-new 'hash-make "19.0")
+(defun hash-new (size)
+ "Return a new hash table of SIZE elements.
+This is obsolete. Use `hash-make' instead."
+ (hash-make size))
+
+(defun hash-prepend (value key hash-table)
+ "Prepend VALUE onto the list value referenced by KEY, a string, in
HASH-TABLE.
+If KEY is not found in HASH-TABLE, it is added with a value of (list VALUE)."
+ (if (hashp hash-table)
+ (let* ((obarray (hash-obarray hash-table))
+ (sym (intern key obarray)))
+ (if (boundp sym)
+ (if (listp (symbol-value sym))
+ (set sym (cons value (symbol-value sym)))
+ (error "(hash-prepend): `%s' key's value is not a list."
+ key))
+ (set sym (cons value nil))))))
+
+(defun hash-prin1 (hash-table &optional stream)
+ "Output the printed representation of HASH-TABLE as a list.
+Quoting characters are printed when needed to make output that `read'
+can handle, whenever this is possible.
+Output stream is STREAM, or value of `standard-output'."
+ (if (not (hashp hash-table))
+ (progn (prin1 hash-table stream)
+ (princ "\n" stream))
+ (princ "\(\n" stream)
+ (hash-map
+ (lambda (val-key-cons)
+ (prin1 val-key-cons stream)
+ (princ "\n" stream))
+ hash-table)
+ (princ "\)\n" stream)))
+
+(defun hash-replace (value key hash-table)
+ "Replace VALUE referenced by KEY, a string, in HASH-TABLE.
+An error will occur if KEY is not found in HASH-TABLE."
+ (if (hashp hash-table)
+ (let* ((obarray (hash-obarray hash-table))
+ (sym (intern-soft key obarray)))
+ (if (and (boundp sym) sym)
+ (set sym value)
+ (error "(hash-replace): `%s' key not found in hash table." key)))))
+
+(defun hash-resize (hash-table new-size)
+ "Resize HASH-TABLE to NEW-SIZE without losing any elements and return new
table.
+NEW-SIZE must be greater than 0. Hashing works best if NEW-SIZE is a prime
+number. See also `hash-next-prime'."
+ (if (< new-size 1)
+ (error "(hash-resize): Cannot resize hash table to size %d" new-size))
+ (let ((htable (hash-make new-size)))
+ (hash-map (lambda (elt)
+ (hash-add (car elt) (cdr elt) htable))
+ hash-table)
+ htable))
+
+(defun hash-resize-p (hash-table)
+ "Resizes HASH-TABLE to 1.5 times its size if above 80% full.
+Returns new hash table when resized, else nil."
+ (if (hashp hash-table)
+ (let ((count (hash-count hash-table))
+ (size (length (hash-obarray hash-table))))
+ (if (> (* count (/ count 5)) size)
+ (hash-resize hash-table (hash-next-prime (+ size (/ size 2))))))))
+
+(defun hash-size (hash-table)
+ "Return size of HASH-TABLE which is >= number of elements in the table.
+Return nil if not a valid hash table."
+ (if (hashp hash-table)
+ (length (hash-obarray hash-table))))
+(defalias 'hash-length 'hash-size)
+
+(defun hashp (object)
+ "Return non-nil if OBJECT is a hash-table."
+ (and (listp object) (eq (car object) 'hasht)
+ (vectorp (cdr object))))
+
+;;; ************************************************************************
+;;; Private functions
+;;; ************************************************************************
+
+(defun hash-next-prime (n)
+ "Return next prime number >= N."
+ (if (<= n 2)
+ 2
+ (and (= (% n 2) 0) (setq n (1+ n)))
+ (while (not (hash-prime-p n))
+ (setq n (+ n 2)))
+ n))
+
+(defun hash-obarray (hash-table)
+ "Return symbol table (object array) portion of HASH-TABLE."
+ (cdr hash-table))
+
+(defun hash-prime-p (n)
+ "Return non-nil iff N is prime."
+ (if (< n 0) (setq n (- n)))
+ (let ((small-primes '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67
71 73 79 83 89)))
+ (cond ((< n 2) nil)
+ ((< n 91) (if (memq n small-primes) t))
+ ((< n 7921) ;; 89, max small-prime, squared
+ (let ((prime t)
+ (pr-list small-primes))
+ (while (and (setq pr-list (cdr pr-list))
+ (setq prime (/= (% n (car pr-list)) 0))))
+ prime))
+ ((or (= (% n 3) 0) (= (% n 2) 0)) nil)
+ ((let ((factor1 5)
+ (factor2 7)
+ (is-prime))
+ (while (and (<= (* factor1 factor1) n)
+ (setq is-prime (and (/= (% n factor1) 0)
+ (/= (% n factor2) 0))))
+ (setq factor1 (+ factor1 6)
+ factor2 (+ factor2 6)))
+ is-prime)))))
+
+(defun hash-set-of-strings (sorted-strings &optional count)
+ "Return SORTED-STRINGS list with any duplicate entries removed.
+Optional COUNT conses number of duplicates on to front of list before return."
+ (and count (setq count 0))
+ (let ((elt1) (elt2) (lst sorted-strings)
+ (test (if count
+ (lambda (a b) (if (string-equal a b)
+ (setq count (1+ count))))
+ (lambda (a b) (string-equal a b)))))
+ (while (setq elt1 (car lst) elt2 (car (cdr lst)))
+ (if (funcall test elt1 elt2)
+ (setcdr lst (cdr (cdr lst)))
+ (setq lst (cdr lst)))))
+ (if count (cons count sorted-strings) sorted-strings))
+
+;;; ************************************************************************
+;;; Private variables
+;;; ************************************************************************
+
+(defvar hash-empty-htable (hash-make 1)
+ "Empty hash table used to test whether other hash tables are empty.")
+
+(provide 'hasht)
diff --git a/hibtypes.el b/hibtypes.el
index 8246fbd355..d0241216ca 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: 7-Apr-24 at 15:12:46 by Bob Weiner
+;; Last-Mod: 22-Apr-24 at 02:06:09 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -11,6 +11,7 @@
;; See the "HY-COPY" file for license information.
;;
;; This file is part of GNU Hyperbole.
+
;;; Commentary:
;;
;; Implicit button types (ibtypes) in this file are defined in increasing
@@ -88,6 +89,12 @@
;; them. Use load instead to ensure are reloaded when resetting
;; ibtype priorities.
+;;; ========================================================================
+;;; Creates and display personal wiki pages with auto-wikiword links
+;;; ========================================================================
+
+(load "hywiki")
+
;;; ========================================================================
;;; Jumps to source line from Python traceback lines
;;; ========================================================================
diff --git a/hsys-org.el b/hsys-org.el
index d847ba05c5..6d7f6f9882 100644
--- a/hsys-org.el
+++ b/hsys-org.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 2-Jul-16 at 14:54:14
-;; Last-Mod: 14-Apr-24 at 11:37:50 by Bob Weiner
+;; Last-Mod: 21-Apr-24 at 12:17:44 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -398,10 +398,25 @@ Return the (start . end) buffer positions of the region."
(defun hsys-org-link-at-p ()
"Return non-nil iff point is on a square-bracketed Org mode link.
Assume caller has already checked that the current buffer is in `org-mode'
-or are looking for an Org link in another buffer type."
+or is looking for an Org link in another buffer type."
(unless (or (smart-eolp) (smart-eobp))
(with-suppressed-warnings nil
- (org-in-regexp org-link-bracket-re nil t))))
+ (let ((in-org-link (org-in-regexp org-link-bracket-re nil t)))
+ (when in-org-link
+ (save-match-data
+ ;; If this Org link matches a HyWiki word, let Org handle
+ ;; it with its normal internal link handling only if it
+ ;; has a `hywiki-org-link-type' prefix or if
+ ;; `hywiki-org-link-type-required' is non-nil. Otherwise,
+ ;; return nil from this function and let ibtypes handle this
+ ;; as a HyWiki word.
+ (if (fboundp 'hywiki-at-wikiword)
+ (if (hywiki-at-wikiword t)
+ (when (or hywiki-org-link-type-required
+ (hyperb:stack-frame '(hywiki-at-wikiword)))
+ in-org-link)
+ in-org-link)
+ in-org-link)))))))
;; Assume caller has already checked that the current buffer is in org-mode.
(defun hsys-org-heading-at-p (&optional _)
diff --git a/hui-em-but.el b/hui-em-but.el
index 73d0aeaf88..9c9fa36f55 100644
--- a/hui-em-but.el
+++ b/hui-em-but.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 21-Aug-92
-;; Last-Mod: 20-Jan-24 at 20:09:40 by Mats Lidell
+;; Last-Mod: 22-Apr-24 at 02:06:26 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -159,10 +159,13 @@ moves over it."
(when hproperty:but-emphasize-flag
(overlay-put but 'mouse-face 'highlight))))
-(defun hproperty:but-clear (&optional pos)
- "Remove highlighting from any named Hyperbole button at point or POS."
- (let ((but (hproperty:but-get pos)))
- (when but (delete-overlay but))))
+(defun hproperty:but-clear (&optional pos property value)
+ "Remove highlighting from any named Hyperbole button at point or POS.
+If optional PROPERTY and VALUE are given, remove highlighting only if
+the PROPERTY at the position matches VALUE."
+ (let ((but (hproperty:but-get pos property value)))
+ (when but
+ (delete-overlay but))))
(defun hproperty:but-clear-all (&optional regexp-match)
"Remove highlighting from all named Hyperbole buttons in buffer.
@@ -217,23 +220,41 @@ moves over it."
(narrow-to-region start end)
(hproperty:but-create-all)))
+(defun hproperty:but-delete (hproperty-but)
+ "Remove HPROPERTY-BUT. See `hproperty:but-get'."
+ (delete-overlay hproperty-but))
+
+(defun hproperty:but-end (hproperty-but)
+ "Return the start position of an HPROPERTY-BUT.
+See `hproperty:but-get'."
+ (overlay-end hproperty-but))
+
+(defun hproperty:but-get (&optional pos property value)
+ "Get button at optional POS or point.
+If optional PROPERTY and VALUE are given, return only the first button
+with that PROPERTY and VALUE."
+ (car (delq nil
+ (mapcar (lambda (overlay)
+ (when (memq (overlay-get overlay (or property 'face))
+ (if property
+ (list value)
+ (list hproperty:but-face
+ hproperty:ibut-face
+ hproperty:flash-face)))
+ overlay))
+ (overlays-at (or pos (point)))))))
+
+(defun hproperty:but-start (hproperty-but)
+ "Return the end position of an HPROPERTY-BUT.
+See `hproperty:but-get'."
+ (overlay-start hproperty-but))
+
(add-to-list 'yank-handled-properties '(hproperty:but-face .
hproperty:but-create-on-yank))
;;; ************************************************************************
;;; Private functions
;;; ************************************************************************
-(defun hproperty:but-get (&optional pos)
- "Get button property at optional POS or point."
- (car (delq nil
- (mapcar (lambda (props)
- (if (memq (overlay-get props 'face)
- (list hproperty:but-face
- hproperty:ibut-face
- hproperty:flash-face))
- props))
- (overlays-at (or pos (point)))))))
-
(defsubst hproperty:list-cycle (list-ptr list)
"Move LIST-PTR to next element in LIST or when at end to first element."
(or (and list-ptr (setq list-ptr (cdr list-ptr)))
@@ -277,11 +298,13 @@ hproperty:color-ptr."
(redisplay t)
t))
-(defun hproperty:but-p (&optional pos)
+(defun hproperty:but-p (&optional pos property value)
"Return non-nil at point or optional POS iff on a highlighted Hyperbole
button."
- (memq t (mapcar (lambda (props)
- (when (memq (overlay-get props 'face)
- (list hproperty:but-face hproperty:ibut-face))
+ (memq t (mapcar (lambda (overlay)
+ (when (memq (overlay-get overlay (or property 'face))
+ (if property
+ (list value)
+ (list hproperty:but-face
hproperty:ibut-face)))
t))
(overlays-at (or pos (point))))))
diff --git a/hywiki.el b/hywiki.el
new file mode 100644
index 0000000000..0e3798ef40
--- /dev/null
+++ b/hywiki.el
@@ -0,0 +1,433 @@
+;;; hywiki.el --- Hyperbole's auto-wikiword note-taking system -*-
lexical-binding: t -*-
+;;
+;; Author: Bob Weiner
+;;
+;; Orig-Date: 21-Apr-24 at 22:41:13
+;; Last-Mod: 22-Apr-24 at 02:22:28 by Bob Weiner
+;;
+;; SPDX-License-Identifier: GPL-3.0-or-later
+;;
+;; Copyright (C) 2024 Free Software Foundation, Inc.
+;; See the "HY-COPY" file for license information.
+;;
+;; This file is part of GNU Hyperbole.
+
+;;; Commentary:
+;;
+;; This is Hyperbole's markup-free personal Wiki system for
+;; note-taking and automatic WikiWord hyperlinking. A `HyWiki word'
+;; starts with a capitalized letter and contains only upper and
+;; lowercase letters. `HyWiki pages' are Org or other text mode
+;; files with HyWiki word names (the page name) plus a file-type
+;; suffix which are stored within `hywiki-directory'.
+;;
+;; To create a new HyWiki page or to jump to one, simply create an
+;; Org link in any buffer with the prefix "hy:" followed by a
+;; capitalized alpha characters-only WikiWord, e.g. [[hy:Emacs]], and
+;; then press the Action Key on the link to jump to the associated
+;; page. You will be prompted to create the page if it does not
+;; exist.
+
+;; If you set `hywiki-org-link-type-required' to `nil', then
+;; you don't need the prefix, e.g. [[Emacs]] and existing HyWiki page
+;; names will override Org's standard handling of such links. To
+;; prevent Org mode's binding of {M-RET} from splitting lines and
+;; creating new headlines when on a HyWiki word whose page has not
+;; yet been created, set `hsys-org-enable-smart-keys' to 't' so that
+;; Hyperbole's Action Key does the right thing in this context.
+;;
+;; HyWiki pages are created in `hywiki-directory'. Within such
+;; pages, WikiWords (the names of HyWiki pages) work without the need
+;; for any delimiters. Simply type them out, e.g. Emacs and if a
+;; page exists for the word, it is automatically highlighted when:
+;; - a HyWiki page file is read in
+;; - a whitespace character is inserted following a HyWiki word
+;; - the Action Key is pressed to activate a HyWiki word button.
+;;
+;; HyWiki links can also link to a section headline within a page by
+;; simply following the page name a '#' character and then the
+;; section headline name. For example, if your Emacs page has a
+;; 'Major Modes section, then either [[hy:Emacs#Major Modes]] or
+;; Emacs#Major-Modes will work as a link to that section. Note that
+;; without the square bracket delimiters, you must convert spaces in
+;; section names to '-' characters.
+;;
+;; Although HyWiki creates new pages in Org mode, you can manually
+;; insert pages in Markdown or other text modes within
+;; `hywiki-directory' and then link to them. You can also change the
+;; default `hywiki-file-suffix' to something else, like ".md" to have
+;; HyWiki use Markdown mode for its pages. This usage has not yet
+;; been tested though, so use at your own risk.
+
+;;; Code:
+;;; ************************************************************************
+;;; Other required Elisp libraries
+;;; ************************************************************************
+
+(require 'hasht)
+(require 'hui-em-but)
+(require 'ol)
+
+(when (package-installed-p 'company)
+ (package-activate 'company)
+ (require 'company)
+ (add-to-list 'company-backends 'hywiki-company-hasht-backend))
+
+;;; ************************************************************************
+;;; Public variables
+;;; ************************************************************************
+
+(defcustom hywiki-word-highlight-flag t
+ "Non-nil means automatically highlight non-Org link HyWiki word
hyperbuttons."
+ :type 'boolean
+ :initialize #'custom-initialize-default
+ :group 'hyperbole-buttons)
+
+(defvar hywiki-file-suffix ".org"
+ "File suffix (including period) to use when creating HyWiki pages.")
+
+(defvar hywiki-allowed-modes '(text-mode wiki-mode)
+ "Parent modes where HyWiki words are recognized without delimiters.
+Applies only when the file is below `hywiki-directory'.")
+
+(defconst hywiki-directory '"~/hywiki/"
+ "Directory in which to find HyWiki page files.")
+
+(defconst hywiki-org-link-type "hy:"
+ "HyWiki string prefix type for Org links.")
+
+(defvar hywiki-org-link-type-required t
+ "When non-nil, HyWiki Org links must start with `hywiki-org-link-type'.
+Otherwise, this prefix is not needed and HyWiki word Org links
+override standard Org link lookups. See \"(org)Internal Links\".")
+
+(defvar hywiki-pages-hasht nil)
+
+(defconst hywiki-word-regexp
+ "\\<\\([[:upper:]][[:alpha:]]+\\)\\>"
+ "Regexp that matches a HyWiki word only.")
+
+(defconst hywiki-word-optional-section-regexp
+ (concat hywiki-word-regexp "\\(#[^][ \t\n\r\f]+\\)?")
+ "Regexp that matches a HyWiki word with an optional #section.
+Section may not contain spaces or square brackets. Use '-' to
+substitute for spaces in the section/headline name. Grouping 1 is
+the HyWiki word and grouping 2 is the #section with the # included.")
+
+(defconst hywiki-word-org-link-regexp
+ (concat hywiki-word-regexp "\\(#[^][\n\r\f]+\\)?")
+ "Regexp that matches a HyWiki word with an optional #section in an Org link.
+Section may not contain spaces or square brackets. Use '-' to
+substitute for spaces in the section/headline name. Grouping 1 is
+the HyWiki word and grouping 2 is the #section with the # included.")
+
+(defface hywiki--word-face
+ '((((min-colors 88) (background dark)) (:foreground "mediumbrown"))
+ (((background dark)) (:background "orange" :foreground "black"))
+ (((min-colors 88)) (:foreground "darkbrown"))
+ (t (:background "orange")))
+ "Face for HyWiki word highlighting."
+ :group 'hyperbole-buttons)
+
+(defcustom hywiki-word-face 'hywiki--word-face
+ "Hyperbole face for HyWiki word highlighting."
+ :type 'face
+ :initialize #'custom-initialize-default
+ :group 'hyperbole-buttons)
+
+;;; ************************************************************************
+;;; Public Implicit Button and Action Types
+;;; ************************************************************************
+
+;;;###autoload
+(defib hywiki ()
+ "When on a HyWiki word, display its page and optional section."
+ (let* ((page-name (hywiki-at-wikiword)))
+ (when page-name
+ (ibut:label-set page-name (match-beginning 0) (match-end 0))
+ (hywiki-highlight-page-name t)
+ (hact 'hywiki-open page-name))))
+
+;;;###autoload
+(defun hywiki-open (page-name)
+ "Display HyWiki PAGE-NAME. Prompt to create if non-existent."
+ (interactive (list (completing-read "HyWiki page: " (hywiki-page-list))))
+ (let* ((section (when (string-match "#" page-name)
+ (substring page-name (match-beginning 0))))
+ (page-name (if (string-match "#" page-name)
+ (substring page-name 0 (match-beginning 0))
+ page-name))
+ (page-file (or (hywiki-get-page page-name)
+ (when (y-or-n-p (concat "Create missing page, "
page-name "? "))
+ (hywiki-add-page page-name)))))
+ (when page-file
+ (hpath:find (concat page-file section)))))
+
+;;; ************************************************************************
+;;; Public functions
+;;; ************************************************************************
+
+(defun hywiki-at-wikiword (&optional org-link-flag)
+ "Return HyWiki word and optional #section at point or nil if not on one."
+ (let (wikiword)
+ (if (or org-link-flag (hsys-org-link-at-p))
+ ;; Handle an Org link [[HyWiki word]] [[hy:HyWiki word]] or [[HyWiki
word#section]]
+ (progn
+ (setq wikiword
+ (org-link-expand-abbrev
+ (org-link-unescape
+ (string-trim (match-string-no-properties 1)))))
+ ;; Ignore hy:word hywiki:word since Org mode will display those
+ (when (hywiki-is-wikiword wikiword)
+ wikiword))
+ ;; Handle a HyWiki word with optional #section; if it is an Org
+ ;; link, it may or may not have a hy: link-type prefix.
+ (and (apply #'derived-mode-p hywiki-allowed-modes)
+ (string-prefix-p (expand-file-name hywiki-directory)
+ (or buffer-file-name ""))
+ (save-excursion
+ (let ((case-fold-search nil))
+ (skip-chars-backward "-*#[:alpha:]")
+ ;; Ignore wikiwords preceded by any non-whitespace character
+ (and (or (bolp) (memq (preceding-char) '(?\[ ?\ ?\t ?\n ?\r
?\f)))
+ (looking-at hywiki-word-optional-section-regexp)
+ (string-trim (match-string-no-properties 0)))))))))
+
+(defun hywiki-highlight-page-names ()
+ "Highlight all non-Org link HyWiki page names in the buffer.
+Use `hywiki-word-face' to highlight. Does not highlight references to
+the current page unless they have sections attached.
+
+Used as a `find-file-hook'."
+ (interactive)
+ ;; Highlight HyWiki words only in files below `hywiki-directory'
+ (when (and hywiki-word-highlight-flag
+ (string-prefix-p (expand-file-name hywiki-directory)
+ (or buffer-file-name "")))
+ (let ((any-page (string-join (hywiki-page-list) "\\|"))
+ (case-fold-search nil)
+ (hywiki-org-link-type-required t)
+ current-page
+ start
+ end)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward (format "\\<\\(%s\\)\\>" any-page) nil t)
+ (setq start (match-beginning 0)
+ end (match-end 0))
+ (save-excursion
+ (goto-char start)
+ ;; Ignore wikiwords preceded by any non-whitespace character
+ (when (or (bolp) (memq (preceding-char) '(?\ ?\t)))
+ ;; Include any #section
+ (skip-chars-forward "-#[:alpha:]")
+ (setq end (point)
+ current-page (hywiki-get-buffer-page-name))
+ ;; Don't highlight current-page matches unless
+ ;; they include a #section.
+ (unless (string-equal current-page
+ (buffer-substring-no-properties start
end))
+ (hproperty:but-add start end hywiki-word-face))))))))))
+
+(defun hywiki-highlight-page-name (&optional on-page-name)
+ "Highlight any non-Org link HyWiki page name one character before point.
+With optional ON-PAGE-NAME non-nil, assume point is within the page or
+section name.
+
+Use `hywiki-word-face' to highlight. Does not highlight references to
+the current page unless they have sections attached.
+
+Used as a `post-self-insert-hook'."
+ (interactive)
+ (when (and hywiki-word-highlight-flag
+ (or on-page-name
+ (and (eq (char-before) last-command-event) ; Sanity check
+ (not (eq ?# last-command-event))
+ (memq (char-syntax last-command-event) '(?\ ?\) ?\$ ?\>
?. ?\" ?\'))))
+ (not executing-kbd-macro)
+ (not noninteractive)
+ (string-prefix-p (expand-file-name hywiki-directory)
+ (or buffer-file-name "")))
+ (let ((case-fold-search nil)
+ (hywiki-org-link-type-required t)
+ but
+ current-page
+ page-name
+ start
+ end)
+ (save-excursion
+ (if on-page-name
+ (progn (skip-syntax-backward "^-\)$\>.\"\'")
+ (skip-chars-backward "#[:alpha:]"))
+ ;; after page name
+ (goto-char (max (1- (point)) (point-min)))
+ (skip-chars-backward "-#[:alpha:]"))
+ (if (and (looking-at hywiki-word-optional-section-regexp)
+ ;; Ignore wikiwords preceded by any non-whitespace character
+ (or (bolp) (memq (preceding-char) '(?\ ?\t ?\n ?\r ?\f)))
+ (progn
+ (setq page-name (match-string-no-properties 1)
+ start (match-beginning 0)
+ end (match-end 0))
+ (and (hywiki-get-page page-name)
+ ;; Ignore wikiwords preceded by any non-whitespace
character
+ (or (bolp) (memq (preceding-char) '(?\ ?\t))))))
+ (progn
+ (setq current-page (hywiki-get-buffer-page-name))
+ ;; Don't highlight current-page matches unless
+ ;; they include a #section.
+ (unless (string-equal current-page
+ (buffer-substring-no-properties start end))
+ (if (setq but (hproperty:but-get (point) 'face
hywiki-word-face))
+ (progn
+ (setq but-start (hproperty:but-start but)
+ but-end (hproperty:but-end but))
+ (unless (and (= start but-start) (= end but-end))
+ (hproperty:but-delete but)
+ (hproperty:but-add start end hywiki-word-face)))
+ (hproperty:but-add start end hywiki-word-face))))
+ ;; Remove any potential earlier highlighting since the
+ ;; previous word may have changed.
+ (skip-syntax-backward "^-\)$\>.\"\'")
+ (hproperty:but-clear (point) 'face hywiki-word-face))))))
+
+(defun hywiki-is-wikiword (word)
+ "Return non-nil if WORD is a HyWiki word and optional #section.
+The page for the word may not yet exist. Use `hywiki-get-page'
+to determine whether a HyWiki word page exists."
+ (and (stringp word)
+ (or (eq (string-match (concat "\\`" hywiki-word-org-link-regexp "\\'")
word)
+ 0)
+ (eq (string-match (concat "\\`" hywiki-word-optional-section-regexp
"\\'") word)
+ 0))))
+
+(defun hywiki-get-buffer-page-name ()
+ "Extract the page name from the buffer file name or else buffer name."
+ (file-name-sans-extension (file-name-nondirectory
+ (or buffer-file-name (buffer-name)))))
+
+(defun hywiki-get-pages ()
+ (or hywiki-pages-hasht (hywiki-make-pages-hasht)))
+
+(defun hywiki-get-page-files ()
+ "Return the list of existing HyWiki page file names.
+These may have any alphanumeric file suffix, if files were added manually."
+ (directory-files-recursively hywiki-directory (concat "^" hywiki-word-regexp
"\\.[A-Za-z0-9]$")))
+
+(defun hywiki-get-page-file (page-name)
+ "Return possibly non-existent file name for PAGE NAME.
+No validation of PAGE-NAME is done."
+ (concat (expand-file-name page-name hywiki-directory) hywiki-file-suffix))
+
+(defun hywiki-make-pages-hasht ()
+ (let* ((page-files (hywiki-get-page-files))
+ (page-elts (mapcar (lambda (file)
+ (cons file (file-name-sans-extension
(file-name-nondirectory file))))
+ page-files)))
+ (setq hywiki-pages-hasht (hash-make page-elts))))
+
+(defun hywiki-get-page (page-name)
+ "Return the absolute path of HyWiki PAGE-NAME or nil if it does not exist."
+ (if (and (stringp page-name) (not (string-empty-p page-name))
+ (eq (string-match hywiki-word-org-link-regexp page-name) 0))
+ (progn
+ (when (match-string-no-properties 2 page-name)
+ ;; Remove any #section suffix in PAGE-NAME.
+ (setq page-name (match-string-no-properties 1 page-name)))
+
+ (or (hash-get page-name (hywiki-get-pages))
+ ;; If page exists but not yet in lookup hash table, add it.
+ (when (file-readable-p (hywiki-get-page-file page-name))
+ (hywiki-add-page page-name))))
+ (user-error "(hywiki-get-page): Invalid page name: '%s'; must be
capitalized, all alpha" page-name)))
+
+(defun hywiki-add-page (page-name)
+ "Add the HyWiki page for PAGE-NAME and return its file.
+If file exists already, just return it. If PAGE-NAME is invalid,
+return nil.
+
+Use `hywiki-get-page' to determine whether a HyWiki page exists."
+ (if (and (stringp page-name) (not (string-empty-p page-name))
+ (eq (string-match hywiki-word-org-link-regexp page-name) 0))
+ (progn
+ (when (match-string-no-properties 2 page-name)
+ ;; Remove any #section suffix in PAGE-NAME.
+ (setq page-name (match-string-no-properties 1 page-name)))
+
+ (let ((page-file (hywiki-get-page-file page-name))
+ (pages-hasht (hywiki-get-pages)))
+ (unless (file-readable-p page-file)
+ ;; Create any parent dirs necessary to create empty file
+ (make-empty-file page-file t))
+ (unless (hash-get page-name pages-hasht)
+ (hash-add page-file page-name pages-hasht))
+ page-file))
+ (user-error "(hywiki-add-page): Invalid page name: '%s'; must be
capitalized, all alpha" page-name)))
+
+(defun hywiki-add-to-page (page-name text start-flag)
+ "Add to PAGE-NAME TEXT at page start with START-FLAG non-nil, else end.
+Create page if it does not exist. If PAGE-NAME is invalid, return
+nil, else return the file name of the page."
+ (let* ((page-file (hywiki-add-page page-name))
+ (page-buf (when page-file (find-file-noselect page-file))))
+ (when page-buf
+ (save-excursion
+ (set-buffer page-buf)
+ (barf-if-buffer-read-only)
+ (save-restriction
+ (widen)
+ (goto-char (if start-flag (point-min) (point-max)))
+ (unless (bolp) (insert (newline)))
+ (insert text)
+ (unless (bolp) (insert (newline)))
+ (goto-char (if start-flag (point-min) (point-max)))
+ page-file)))))
+
+(defun hywiki-page-list ()
+ (hash-map #'cdr (hywiki-get-pages)))
+
+(defun hywiki-company-hasht-backend (command &optional arg &rest ignored)
+ "A `company-mode` backend that completes from the keys of a hash table."
+ (interactive (list 'interactive))
+ (when (hywiki-at-wikiword)
+ (case command
+ ('interactive (company-begin-backend 'company-hash-table-backend))
+ ('prefix (company-grab-symbol))
+ ('candidates
+ (let ((prefix (company-grab-symbol)))
+ (when prefix
+ (cl-loop for key being the hash-keys in (hywiki-page-list)
+ when (string-prefix-p prefix key)
+ collect key))))
+ ('sorted t))))
+
+;; HyWiki org link type, abbreviated as 'hy'
+(org-link-set-parameters "hy"
+ :complete #'hywiki-complete
+ :follow #'hywiki-open
+ :store #'hywiki-store-link)
+
+(defun hywiki-complete (&optional _arg)
+ "Complete HyWiki page names for `org-insert-link'."
+ (concat
+ hywiki-org-link-type
+ (let ((completion-ignore-case t))
+ (completing-read "HyWiki page: " (hywiki-page-list) nil t))))
+
+(defun hywiki-store-link ()
+ "Store a link to a HyWiki word at point, if any."
+ (when (hywiki-at-wikiword)
+ (let* ((page-name (hywiki-at-wikiword))
+ (link (concat "hy:" page-name))
+ (description (format "HyWiki page for %s" page-name)))
+ (org-link-store-props
+ :type hywiki-org-link-type
+ :link link
+ :description description))))
+
+(add-hook 'find-file-hook #'hywiki-highlight-page-names t)
+(add-hook 'post-self-insert-hook #'hywiki-highlight-page-name t)
+
+(provide 'hywiki)
