Most glitches fixed

README.org

@@ -1,7 +1,8 @@
 #+TITLE: Diatheke Interface for Bible Browsing in Emacs
 
 * Description
-An Emacs Bible viewing interface utilizing the SWORD project's Diatheke command line program.
+An Emacs Bible viewing interface using the SWORD project's Diatheke
+command line program to access SWORD text modules.
 * Dependencies
 ~diatheke~ and a Biblical Text module (uses KJV by default). Also,
 Strong's lexicons and morphological databases should be installed:
@@ -10,6 +11,9 @@ Strong's lexicons and morphological databases should be installed:
 - Robinson
 - Packard
 - OSHM
+- AbbottSmith (lexicon) + AbbottSmithStrongs (index)
+- BDBGlosses_Strongs
+
 
 The utility `installmgr' can be used to install text modules and
 lexical and morphological databases.
@@ -25,6 +29,7 @@ lexical search method will work.
 ** Keybindings
 - b - Select book
 - c - Select chapter
+- d - Toggle XML display (debugging)
 - h - Describe mode
 - m - Select module
 - n - Next chapter

bible-mode.el

@@ -1,7 +1,7 @@
 ;;;; -*- mode: EMACS-LISP; lexical-binding: t -*-
 ;;
 ;; bible-mode.el --- A browsing interface for the SWORD Project's Diatheke CLI
-;; Time-stamp: <2024-05-22 09:00:30 fred>
+;; Time-stamp: <2024-05-24 12:13:14 fred>
 
 ;; Author: Zacalot
 ;; Fixes and modifications by Fred Gilham
@@ -63,7 +63,9 @@
 ;;; Code:
 
 ;;;; Requirements
-(require 'cl-lib) ; XXX FMG there are just a few constructs that use this; use elisp versions instead.
+;;; XXX FMG there are just a few constructs that use this; use elisp versions instead.
+;; cl-do* cl-fresh-line
+(require 'cl-lib) 
 ;; (require 'bidi)
 (require 'dom)
 (require 'shr)
@@ -155,8 +157,6 @@
 ;;(defvar bm-verse-regexp "([\d ]*[a-zA-Z]+( \d*:\d*)?)(( - )| )?(((\d* )?[a-zA-Z]+ )?\d*([:-]+\d*)?)")
 ;; (defvar bm-verse-regexp "/(\d*)\s*([a-z]+)\s*(\d+)(?::(\d+))?(\s*-\s*(\d+)(?:\s*([a-z]+)\s*(\d+))?(?::(\d+))?)?/i")
 (defvar bm-verse-regexp "\\(I?I \\)*[a-zA-Z]* [0-9]*:[0-9]*")
-(setq bm-verse-regexp "\\(I?I \\)*[a-zA-Z]* [0-9]*:[0-9]*")
-
 
 (defvar bm-modules (lazy-completion-table bm-modules bm--list-biblical-modules))
 
@@ -233,23 +233,78 @@
 
 ;;;; Keymaps
 
-(defconst bm-map (make-keymap))
+(defconst bm-map (make-sparse-keymap)
+  "Keymap for bible-mode.")
+(define-key bm-map [menu-bar bible-mode]
+	    (cons "Bible Mode" (make-sparse-keymap "Bible Mode")))
+
+(define-key bm-map
+	    [menu-bar bible-mode toggle-debug]
+	    '("Toggle debug-on-error" . toggle-debug-on-error))
+
+(defun bm-toggle-display-xml ()
+  "Toggle XML display."
+  (interactive)
+  (setq-local bm-debugme (not bm-debugme))
+  (bm--display))
+
+(define-key bm-map "d" 'bm-toggle-display-xml)
+(define-key bm-map 
+	    [menu-bar bible-mode display-xml]
+	    '("Toggle XML Display" . bm-toggle-display-xml))
+
+(define-key bm-map
+	    [menu-bar bible-mode sep]
+	    '(menu-item '"--"))
+
+
 ;;;;; Navigation
 (define-key bm-map "n" 'bm-next-chapter)
+(define-key bm-map
+	    [menu-bar bible-mode next-chapter]
+	    '("Next Chapter" . bm-next-chapter))
+	    
 (define-key bm-map "p" 'bm-previous-chapter)
+(define-key bm-map
+	    [menu-bar bible-mode previous-chapter]
+	    '("Previous Chapter" . bm-previous-chapter))
+
 (define-key bm-map (kbd "TAB") 'bm-forward-word) ; TODO: bm-forward-word
+
 ;;;;; Direct jump
 (define-key bm-map "b" 'bm-select-book)
+(define-key bm-map
+	    [menu-bar bible-mode select-book]
+	    '("Select Book" . bm-select-book))
+
 (define-key bm-map "c" 'bm-select-chapter)
+(define-key bm-map
+	    [menu-bar bible-mode select-chapter]
+	    '("Select Chapter" . bm-select-chapter))
+
 ;;;;; Search
-(define-key bm-map "s" 'bible-search)
 (define-key bm-map "/" 'bible-search)
+(define-key bm-map "s" 'bible-search)
+(define-key bm-map
+	    [menu-bar bible-mode search]
+	    '("Bible Search" . bible-search))
+
 ;;;; Not yet
 ;;(define-key bm-map "" 'bm-set-search-range)
 ;;;;; Misc
 (define-key bm-map "m" 'bm-select-module)
 (define-key bm-map "w" 'bm-toggle-word-study)
+
 (define-key bm-map "x" 'bm-split-display)
+(define-key bm-map
+	    [menu-bar bible-mode split-display]
+	    '("Split Display" . bm-split-display))
+
+(define-key bm-map
+	    [menu-bar bible-mode sep]
+	    '(menu-item '"--"))
+
+
 ;;;;; Deal with visual-line-mode
 (define-key bm-map "\C-n" 'next-logical-line)
 (define-key bm-map "\C-p" 'previous-logical-line)
@@ -268,59 +323,51 @@
 ;;; Menu bar items
 ;;;
 
-(define-key global-map [menu-bar bible-mode]
-	    (cons "Bible Mode" (make-sparse-keymap "Bible Mode")))
+(defvar-local bm-text-direction 'left-to-right)
 
-(defun bible-set-left-to-right ()
+(defun bm-toggle-text-direction ()
   (interactive)
-  (setq-local bidi-paragraph-direction 'left-to-right))
+  (if (eq bm-text-direction 'left-to-right)
+      (setq-local bm-text-direction 'right-to-left)
+    (setq-local bm-text-direction 'left-to-right))
+  (setq-local bidi-paragraph-direction bm-text-direction))
 
-(defun bible-set-right-to-left ()
-  (interactive)
-  (setq-local bidi-paragraph-direction 'right-to-left))
+(defvar-local bm-debugme nil
+  "Make text show up as XML when set.")
 
-(define-key global-map
-	    [menu-bar bible-mode left-to-right]
-	    '("Left-to-right" . bible-set-left-to-right))
 
-(define-key global-map 
-	    [menu-bar bible-mode right-to-left]
-	    '("Right-to-left" . bible-set-right-to-left))
 
-(defvar-local bm-debugme nil
-  "Make text show up as XML when set.")
 
-(defun bible-set-display-xml ()
-  "Turn on XML display."
-  (interactive)
-  (setq-local bm-debugme t)
-  (bm--display))
+(defvar use-tooltips t)
 
-(defun bm-set-display-text ()
-  "Turn off XML display."
+(defun bm-toggle-tooltips ()
+  "Toggle use of tooltips to display lexical/morphological items."
   (interactive)
-  (setq-local bm-debugme nil)
-  (bm--display))
+  (setq use-tooltips (not use-tooltips))
+  (tooltip-mode 'toggle)
+  (setq tooltip-resize-echo-area use-tooltips))
 
 
-(define-key global-map 
-	    [menu-bar bible-mode display-xml]
-	    '("Display XML" . bm-set-display-xml))
 
-(define-key global-map 
-	    [menu-bar bible-mode display-text]
-	    '("Display Text" . bm-set-display-text))
+(define-key bm-map
+	    [menu-bar bible-mode sepp]
+	    '(menu-item '"--"))
 
+(define-key bm-map
+	    [menu-bar bible-mode toggle-text-direction]
+	    '("Toggle text direction (for Hebrew display)" . bm-toggle-text-direction))
 
-(define-key global-map
-	    [menu-bar bible-mode select-biblical-text]
-	    '("Select Module" . bm--display-available-modules))
+(define-key bm-map
+	    [menu-bar bible-mode toggle-tooltip-display]
+	    '("Toggle Tooltip Display" . bm-toggle-tooltips))
 
+(define-key bm-map
+	    [menu-bar bible-mode sepp]
+	    '(menu-item '"--"))
 
-(define-key global-map
+(define-key bm-map
 	    [menu-bar bible-mode select-biblical-text]
-	    '("Toggle debug-on-error" . toggle-debug-on-error))
-
+	    '("Select Module" . bm-display-available-modules))
 
 (defun bm-display-greek ()
   "This command is run by clicking on text, not directly by the user."
@@ -669,13 +716,21 @@ properties to allow verse cross references. Returns string."
   (with-temp-buffer
     (let ((args (list "diatheke" nil (current-buffer) t "-b" "AbbottSmith" "-o" "m" "-f" "plain" "-k" lemma)))
       (apply 'call-process args)
+      ;; Clean up outlining in the term buffer. Just fix the first
+      ;; level of outline.
       (format-replace-strings
-       '((" I." . "\n    I.")
-	 (" 1." . "\n    1.")
-	 ("      (a)" . "\n       (a)")
+       '((" I." . "\n   I.")
+	 (" 1." . "\n     1.")
+	 (" (a)" . "\n        (a)")
+	 (" (α)" . "\n          (α)")
+	 ("      (i)" . "\n      (i)")
+	 ("      (1)" . "\n      (1)")
 	 (". ." . ".")
 	 (" . " . ". ")))
       (goto-char (point-min))
+      (while (search-forward "\n" nil t)
+	(delete-blank-lines))
+      (goto-char (point-min))
       (while (search-forward-regexp bm-verse-regexp nil t)
 	(put-text-property (match-beginning 0) (match-end 0) 'xref (match-string 0))
 	(put-text-property (match-beginning 0) (match-end 0) 'keymap bible-search-mode-map)
@@ -695,29 +750,25 @@ properties to allow verse cross references. Returns string."
 (defun bm--lookup-strongs-greek-abbott (window object pos)
   "To use Abbott's Lexicon we extract the Strong's key from the text in the
 buffer. Given the Strong's number, get the lemma for that number. Use
-that lemma to lookup the definition in the AbbottStrongs lexicon.
-
-Compiler warns about unused Window argument."
+that lemma to lookup the definition in the AbbottStrongs lexicon."
   (let* ((query (get-text-property pos 'strong object))
 	 (match (string-match "[0-9]+" query)) ; Compiler warns about unused match variable.
 	 (lookup-key (match-string 0 query)))
     (when lookup-key
       (bm--lookup-lex-def-abbott lookup-key))))
 
-
-
 ;;; Not used.
-(defun bm--hebrew-lex-query (query module)
-  "Executes `diatheke' to do hebrew query, renders HTML, returns string. 
-XXX directionality problems."
-  (with-temp-buffer
-    (let ((args (list "diatheke" nil (current-buffer) t "-b" module "-o" "m" "-f" "HTMLHREF" "-k" query)))
-      (apply 'call-process args)
-      (shr-render-region (point-min) (point-max)))))
+;;;;  (defun bm--hebrew-lex-query (query module)
+;;;;    "Executes `diatheke' to do hebrew query, renders HTML, returns string. 
+;;;;  XXX directionality problems."
+;;;;    (with-temp-buffer
+;;;;      (let ((args (list "diatheke" nil (current-buffer) t "-b" module "-o" "m" "-f" "HTMLHREF" "-k" query)))
+;;;;        (apply 'call-process args)
+;;;;        (shr-render-region (point-min) (point-max)))))
 
 (defun bm--lookup-strongs-hebrew (window object pos)
-  "Look up Hebrew lexical data for object at point. If not found in hash table,
-get it from sword database, stash in hash table, and return data.
+  "Look up Hebrew lexical string for object at point. If not found in hash table,
+get it from sword database, stash in hash table, and return string.
 Note: compiler warns about unused `window' argument."
   (let* ((query (get-text-property pos 'strong object))
 	 (match (string-match "[0-9]+" query))         ; Compiler warns about match.
@@ -734,6 +785,22 @@ Note: compiler warns about unused `window' argument."
   (or (gethash query hash)
       (puthash query (bm--morph-query query database) hash)))
 
+(defvar bm-outline-strings
+  '((" I." .  "\n    I.")
+    (" 1." . "\n 1.")
+    (" 2." . "\n 2.")
+    (" 3." . "\n 3.")
+    (" a." . "\n   a.")
+    (" b." . "\n   b.")
+    (" c." . "\n   c.")    
+    (". ." . ".")
+    (" . " . ". ")))
+
+(defun bm-cleanup-tooltip-text (lex-text)
+  (dolist (outline-string bm-outline-strings)
+    (setq lex-text (string-replace (car outline-string) (cdr outline-string) lex-text)))
+    lex-text)
+
 ;;;
 ;;; Get string for tooltip display
 ;;;
@@ -763,7 +830,7 @@ Note: compiler warns about unused `window' argument."
 		   (setq morph-module "OSHM")
 	   	   (bm--morph-database-lookup (replace-regexp-in-string "oshm:" "" morph) morph-module oshm-hash)))))
       (when lex-text
-	(setq lex-morph-text (string-trim (string-fill lex-text 75))))
+	(setq lex-morph-text (string-trim (bm-cleanup-tooltip-text (string-fill lex-text 75)))))
       (when morph-text
 	(setq lex-morph-text 
 	      (concat lex-morph-text "\n\n"
@@ -773,12 +840,20 @@ Note: compiler warns about unused `window' argument."
       ;; to bypass command substitution in the tooltips.
       (setq lex-morph-text (replace-regexp-in-string "\\\\" "" lex-morph-text)))))
 
-
+(defun bm-handle-divine-name (item)
+  (insert "LORD")
+  (let* ((refstart (- (point) (length "LORD")))
+	 (refend (point))
+	 (strongs (dom-attr item 'savlm)))
+    (add-face-text-property refstart refend 'bold)
+    (put-text-property refstart refend 'keymap bm-hebrew-keymap)
+    (when (and strongs (string-match "strong:H.*" strongs))
+      (put-text-property refstart refend 'help-echo 'bm--show-lex-morph)
+      (put-text-property refstart refend 'strong (match-string 0 strongs)))))
 
 (defun bm--process-word (item iproperties)
   "Word study. Add tooltips for definitions and morphologyl. 
 Insert lemmas in buffer. Must be done after item is inserted in buffer."
-
   (let ((word (dom-text item))
 	(morph (dom-attr item 'morph))
 	(savlm (dom-attr item 'savlm))
@@ -789,22 +864,12 @@ Insert lemmas in buffer. Must be done after item is inserted in buffer."
     (let ((refstart (- (point) (length word)))
 	  (refend  (point)))
 
-      ;; Red letter
+      ;; Red letter (Yuck, some modules need this below)
       (when (plist-get iproperties 'jesus)
 	(add-face-text-property refstart refend '(:foreground "red")))
 
       ;; Special case this. XXX Some modules do this differently.
-      (when divinename
-	(insert "LORD")
-	(let* ((refstart (- (point) (length "LORD")))
-	       (refend (point))
-	       (strongs (dom-attr item 'savlm)))
-	  (string-match "strong:H.*" strongs)
-	  (let ((strongs-ref (match-string 0 strongs)))
-	    (add-face-text-property refstart refend 'bold)
-      	    (put-text-property refstart refend 'keymap bm-hebrew-keymap)
-	    (put-text-property refstart refend 'help-echo 'bm--show-lex-morph)
-	    (put-text-property refstart refend 'strong strongs-ref))))
+      (when divinename (bm-handle-divine-name item))
 
       ;; lexical definitions
       (when savlm
@@ -849,6 +914,11 @@ Insert lemmas in buffer. Must be done after item is inserted in buffer."
 	    (put-text-property refstart refend 'keymap bm-lemma-keymap)))))))
 
 
+(defun bm-new-line ()
+  "Ensure beginning of line. Avoid redundant blank lines."
+  (unless (= (current-column) 0)
+    (insert "\n")))
+
 (defun bm--insert-domnode-recursive (node &optional iproperties notitle)
   "Recursively parses a domnode from `libxml-parse-html-region's usage on text
 produced by `bm--exec-diatheke'. Outputs text to active buffer 
@@ -860,41 +930,46 @@ In processing subnodes, each case will prepend a space if it needs it."
       (setq iproperties (plist-put iproperties 'jesus t))
     (setq iproperties nil))
 
-;;  (when (equal (dom-tag node) 'title)
-;;    ;; Space one line down so there's room for the title at the beginning.
-;;    (insert "\n"))
-
   (dolist (subnode (dom-children node))
     (cond ((null subnode) nil)
 	  ((stringp subnode)
-	   ;; Insert the subnode. Highlight the verse references.
-	   (insert subnode)
-	   ;; XXX this is still not quite right
+	   ;; This still goes wrong, but I blame it on the module. ESV2011 in particular.
 	   (let ((verse-start (string-match bm-verse-regexp subnode)))
-	     (when verse-start
-	       (let* ((verse-match (string-trim (match-string 0 subnode)))
-		      (verse-start-text (string-trim-left (substring subnode verse-start (length subnode))))
-		      (start (- (point) 1 (length (string-trim-right verse-start-text)))))
-		 (add-face-text-property start (+ start (length (string-trim-right verse-match))) '(:foreground "purple"))))))
-	  ((eq (dom-tag subnode) 'title)
-	   (if notitle nil
-	     (progn
-	       (setq bm-chapter-title subnode))))
+	     (if verse-start
+		 (progn
+		   (when (= verse-start 0)
+		     (bm-new-line))
+		   ;; Insert the subnode. Highlight the verse references.
+		   (insert subnode)
+		   (let* ((verse-match (string-trim (match-string 0 subnode)))
+			  (verse-start-text (string-trim-left (substring subnode verse-start (length subnode))))
+			  (start (- (point) 1 (length (string-trim-right verse-start-text)))))
+		     (add-face-text-property start (+ start (length (string-trim-right verse-match))) '(:foreground "purple"))))
+	       (insert subnode)))
+	   ;; Red letter (some modules just have to be different....)
+	   (when (plist-get iproperties 'jesus)
+	     (add-face-text-property (- (point) (length subnode)) (point) '(:foreground "red"))))
+	  ((eq (dom-tag subnode) 'title) 
+	   (when (not notitle) (setq bm-chapter-title subnode)))
 	  ((eq (dom-tag subnode) 'body) (bm--insert-domnode-recursive subnode iproperties notitle))
 	  ((eq (dom-tag subnode) 'seg) ; NASB Module uses this to indicate OT quotations (and others?).
 	   (bm--insert-domnode-recursive subnode iproperties notitle))
+	  ((eq (dom-tag subnode) 'divinename) (bm-handle-divine-name subnode))
+	  ;; This tag is used for red letter.
 	  ((eq (dom-tag subnode) 'q) (bm--insert-domnode-recursive subnode iproperties notitle))
 	  ((eq (dom-tag subnode) 'p) (bm--insert-domnode-recursive subnode iproperties notitle))
 	  ((eq (dom-tag subnode) 'w) (insert " ") (bm--process-word subnode iproperties))
-	  ((eq (dom-tag subnode) 'milestone) (insert "\n"))
-	  ((eq (dom-tag subnode) 'transchange) ; Word inserted by translation, not in original, give visual indication.
+	  ((and (eq (dom-tag subnode) 'milestone) (equal (cdr (assoc 'type (dom-attributes subnode))) "line"))
+	   (bm-new-line))
+	  ((or (eq (dom-tag subnode) 'transchange) 
+	       (eq (dom-tag subnode) 'hi))  
+	   ;; Word inserted by translation, not in original, give visual indication.
 	   (let ((word (dom-text subnode)))
 	     (insert " " word)
 	     (add-face-text-property (- (point) (length word)) (point) '(:foreground "gray50")))))))
 
 
 (defvar bm-debugme nil)
-(setf bm-debugme nil)
 
 (defun bm--display (&optional verse)
   "Renders text for `bible-mode'"