magma-help.el -- help interface for Magma CAS

[Haran Pilpel]

This is a package for those who use the Magma computational algebra
system (http://magma.maths.usyd.edu.au/magma). It provides an
interface to Magma's help files; this is done by spawning a Magma
process and parsing Magma's internal help browser's output.

Unfortunately, it's limited to XEmacs for the moment, so
gnu.emacs.sources is probably not the right place, but there's no
comp.emacs.xemacs.sources.

Any comments, suggestions, critiques, etc. are welcome. This is my
first post here.

Haran

;;; magma-help.el --- major mode for reading Magma help

;; Time-stamp: <04/03/10 10:37:58 haranp>

;; Author: Haran Pilpel <haranp>
;; Version: 1.7
;; Keywords: help, hypermedia, local, user

;;; Commentary:
;; Functions for browsing Magma help.
;; Use this package as follows:
;; Run the function `hp-mh-initialize' to start.
;; This will start Magma (it might take a few seconds), and create and
;; switch to a buffer which contains the output from Magma's help browser.
;; The interface is modeled after Info, and keys function similarly.

;;; ToDo:

;; -- GNU Emacs support.
;; -- Sometimes Magma help provides links to things which can't be
;; `cd'ed to. I consider this a bug in Magma, but it can be worked
;; around. I don't work around it.
;; -- Another Magma help problem: paths do not uniquely identify what
;; they're pointing to. This screws up my wrapper for `walk', for
;; example. Again, I'm treating this as a Magma bug and ignoring it.
;; Note that there is no way (that I know of) to reach this kind of
;; link with any `cd' or `show' command!
;; -- Use a better property than the face to determine what is or isn't
;; a link. This is just laziness on my part.
;; -- Give a nicer way to handle multiple link formats than one
;; gigantic external-link regexp and special-casing in the `goto'
;; function. A list or regexps, which we go through one by one
;; and any match is a link, might be a good idea.
;; -- Add hooks.
;; -- Replace manual fontification with use of font-lock.

;; Customize stuff
(defgroup hp-mh nil
  "Magma Help options."
  :prefix "hp-mh-")

(defface hp-mh-link-type-face
  '((t (:italic t :bold t)))
  "Face used for Magma help links."
  :group 'hp-mh)

(defcustom hp-mh-magma-machine "ceres"
  "Name of machine on which to run Magma."
  :group 'hp-mh
  :type 'string)

(defcustom hp-mh-sleep-period 0.1
  "Amount to sleep when waiting for Magma output."
  :group 'hp-mh
  :type 'number)

;;;; Variables
(defvar hp-mh-process nil
  "Magma process used by the Magma Help package.")

(defvar hp-mh-user-buffer nil
  "Buffer where the user sees the Magma help output.")

(defvar hp-mh-node-history-list nil
  "History of visited Magma help nodes.")

(defvar hp-mh-mode-map nil
  "Keymap used in Magma Help mode.")

(defvar hp-mh-last-output nil
  "Internal variable, don't touch.")

(define-error 'hp-mh-cannot-parse-output
  "Couldn't parse Magma help browser output")

(defconst hp-mh-pwd-output-regexp "Current node: \\(\\S-+\\)"
  "Regexp matching output of Magma `pwd' command. First substring match
is the full path.")

(defconst hp-mh-ls-output-regexp "\\S-+"
  "Regexp matching output of Magma's `ls' command, one match per subtopic.")

; Trailing slashes are pre-squeezed, which makes this regexp a lot simpler.
(defconst hp-mh-explicit-link-regexp
  "\\(\\W//\\S-+\\)\\|\\(\\s-\\[\\+[0-9]+\\]\\)"
  "Regexp matching an explicit Magma link.")

;;;; Major mode setup

;;; Mode map setup
(unless hp-mh-mode-map
  (setq hp-mh-mode-map (make-sparse-keymap))
  (define-key hp-mh-mode-map "F" 'hp-mh-follow-link)
  (define-key hp-mh-mode-map 'return 'hp-mh-follow-link)
  (define-key hp-mh-mode-map "f" 'hp-mh-find)
  (define-key hp-mh-mode-map "u" 'hp-mh-go-up)
  (define-key hp-mh-mode-map "R" 'hp-mh-display-current-node)
  (define-key hp-mh-mode-map "w" 'hp-mh-walk-node)
  (define-key hp-mh-mode-map "b" 'hp-mh-back-node)
  (define-key hp-mh-mode-map "g" 'hp-mh-goto-node)
  (define-key hp-mh-mode-map "G" 'hp-mh-grep)
  (define-key hp-mh-mode-map "d" 'hp-mh-delve)
  (define-key hp-mh-mode-map "q" 'hp-mh-bury-buffer)
  (define-key hp-mh-mode-map "l" 'hp-mh-last)
  (define-key hp-mh-mode-map "s" 'hp-mh-search)
  (define-key hp-mh-mode-map "H" 'hp-mh-home)
  (define-key hp-mh-mode-map "Q" 'hp-mh-terminate)
  (define-key hp-mh-mode-map " " 'hp-mh-scroll-next)
  (define-key hp-mh-mode-map 'backspace 'hp-mh-scroll-prev)
  (define-key hp-mh-mode-map 'tab 'hp-mh-next-reference))

;;;; Functions

;;;; Utility functions: general functions which are useful here
(defun hp-cprot-insert-string-with-face (str fce)
  "Insert a string with a given face."
  (let ((beg (point)))
    (insert str)
    (put-text-property beg (point) 'face fce)))

;; The next two functions can be united into one, which removes all
;; matches of a given regexp in a string.
(defun hp-mh-remove-whitespace (str)
  "Return STR without whitespace."
  (if (string-match search-whitespace-regexp str)
      ; Recursively remove whitespace
      (hp-mh-remove-whitespace (replace-match "" nil nil str))
    str))

(defun hp-mh-squeeze-trailing-slash (str)
  "Return STR, where slash-newline-spaces combinations are removed."
  (if (string-match "\\\\\n *" str)
      ; Recursively remove such combinations.
      (hp-mh-squeeze-trailing-slash (replace-match "" nil nil str))
    str))

;; Some regexp search wrappers.
(defun hp-mh-get-all-matches (regexp str idx &optional start)
  "Return list of matches of REGEXP in STR, starting from START. Matches
are greedy, i.e., the first match is as long as possible (this is the
Emacs regexp default.)"
  (if (string-match regexp str start)
      ; At least one match -- continue recursively.
      (cons (match-string idx str)
            (hp-mh-get-all-matches regexp str idx (match-end 0)))
    ; No matches at all - return nil
    nil))

(defun hp-mh-find-nth-match (regexp str count &optional start)
  "Return the location of the Nth complete match of REGEXP in STR."
  (string-match regexp str start)
  (if (= count 1)
      (match-beginning 0)
    (hp-mh-find-nth-match regexp str (1- count) (match-end 0))))

;; Miscellany
(defun hp-mh-jump-to-next-extent-matching (pred)
  "Go to the beginning of the next exten in the current buffer matching PRED."
  (if (not (= (point) (point-max)))
      (progn
        ; Skip out of the extent if we're currently in one
        (if (extent-at (point))
            (goto-char (next-extent-change (point))))
        ; Go to next extent
        (goto-char (next-extent-change (point)))
        ; Test it
        (if (and (extent-at (point))
                 (funcall pred (extent-at (point))))
            ; It's OK, return
            nil
          ; Continue searching
          (hp-mh-jump-to-next-extent-matching pred)))
    (message "No matching extent found")))

(defun hp-mh-word-limits ()
  "Return a (BEGIN, END) pair which marks the beginning and end of the
current word."
  (save-excursion
    (let ((pnt (point)))
      ; Immensely inefficient...
      (while (looking-at "\\w")
        (goto-char (1+ (point))))
      (cons pnt (point)))))

;;; Initialization and setup
(defun hp-mh-initialize (&optional prefix)
  "Call this function to start Magma Help. With prefix arg, prompt for
machine to run Magma on, otherwise use default from `hp-mh-magma-machine'."
  (interactive "P")
  ; If a Magma process is already running, go there.
  (if (and hp-mh-process hp-mh-user-buffer)
      (switch-to-buffer hp-mh-user-buffer)
    ; Create the process
    (let ((machine (if prefix
                       (read-string "Run on which machine? ")
                     hp-mh-magma-machine)))
      (setq hp-mh-process
            (if machine
                (start-process "*Magma Help process*"
                               " *Magma Help*"
                               "ssh" machine "magma")
              (start-process "*Magma Help process"
                             " *Magma Help*"
                             "magma")))
      ; Set up filters to handle output
      (set-process-filter hp-mh-process 'hp-mh-process-filter)
      (message (concat "Starting Magma on "
                       (or machine "local host") "...")))

    ; While we wait, create the output buffer
    (setq hp-mh-user-buffer (get-buffer-create "*magma help"))
    (switch-to-buffer hp-mh-user-buffer)
    (hp-mh-magma-help-mode)

    (accept-process-output hp-mh-process)
    ; Magma has started, enter the help browser
    (message "Starting help browser...")
    (hp-mh-send-string "??\n")
    (message "Creating first help node...")
    (hp-mh-display-current-node)
    (message "Magma help mode initialized.")))

(defun hp-mh-terminate ()
  "Call this function to end Magma Help."
  (interactive)
  (if hp-mh-process
      (progn
        (hp-mh-send-string "quit\n" t)  ; Quit help browser
        (hp-mh-send-string "quit;\n" t) ; Quite Magma
        (sleep-for hp-mh-sleep-period)  ; Wait for it to terminate
        (if (process-live-p hp-mh-process) ; Now kill it if necessary
            (kill-process hp-mh-process))
        (kill-buffer hp-mh-user-buffer) ; Clean up buffers and variables
        (setq hp-mh-last-output nil
              hp-mh-process nil
              hp-mh-user-buffer nil
              hp-mh-node-history-list nil)
        (message "Magma help terminated."))
    (message "No Magma process running.")))

(defun hp-mh-magma-help-mode ()
  "Major mode for Magma Help buffer.
COMMANDS
\\{hp-mh-mode-mode-map}"
  ; XXX Add support for turning this mode on/off. Not really
  ; necessary because the user shouldn't ever call this himself.

  ; Standard major-mode stuff.
  (interactive)
  (kill-all-local-variables)
  (use-local-map hp-mh-mode-map)
  (setq major-mode 'hp-mh-magma-help-mode
        mode-name "MagmaHelp")
  (suppress-keymap hp-mh-mode-map t))

;;; User commands
(defun hp-mh-home ()
  "Go to starting Magma help node (/)."
  (interactive)
  (hp-mh-goto-node "/"))

(defun hp-mh-search (search-string)
  "Search for help in Magma."
  (interactive "sSearch string: ")
  (hp-mh-send-string (concat "search " search-string "\n"))
  (hp-mh-display-output "Search output\n-------------\n"))

(defun hp-mh-find (find-string)
  "Find help in Magma."
  (interactive "sFind string: ")
  (hp-mh-send-string (concat "find " find-string "\n"))
  (hp-mh-display-output "Find output\n-----------\n"))

(defun hp-mh-grep (grep-string)
  "Grep for help in Magma."
  (interactive "sGrep string: ")
  (message "Grepping...")
  (hp-mh-send-string (concat "grep " grep-string "\n"))
  (message "Grepping...done")
  (hp-mh-display-output "Grep output\n-----------\n"))

(defun hp-mh-delve (delve-string)
  "Delve for help in Magma."
  (interactive "sDelve string: ")
  ; Remember our current node, it's important here
  (let ((curnode (hp-mh-current-node)))
    (hp-mh-send-string (concat "delve " delve-string "\n"))
    (hp-mh-display-output (concat "Delve output (beneath " curnode
                                  ")\n------------\n"))))

(defun hp-mh-follow-link ()
  "Follow a link from a Magma Help output page."
  (interactive)
  (let ((my-extent (extent-at (point))))
    (if (and my-extent
             (equal (extent-property my-extent 'face) 'hp-mh-link-type-face))
        (hp-mh-goto-node (extent-string my-extent))
      (message "No link at point."))))

(defun hp-mh-bury-buffer ()
  "Bury the Magma Help buffer."
  (interactive)
  (bury-buffer hp-mh-user-buffer)
  (switch-to-buffer (other-buffer (current-buffer))))

(defun hp-mh-last ()
  "Return to the last visited Magma Help node."
  (interactive)
  (if hp-mh-node-history-list
      (hp-mh-goto-node (pop hp-mh-node-history-list) t)
    (message "History is empty.")))

(defun hp-mh-next-reference ()
  "Jump to the location of the next reference in the Magma help buffer."
  (interactive)
  (hp-mh-jump-to-next-extent-matching
   (lambda (x) (equal (extent-property x 'face) 'hp-mh-link-type-face))))

(defun hp-mh-go-up ()
  "Go up one level."
  (interactive)
  (hp-mh-goto-node ".."))

(defun hp-mh-walk-node ()
  "Walk the Magma help tree."
  (interactive)
  ; Don't ask why, but you need to send this twice. If you think
  ; about it enough, it makes sense.
  (hp-mh-send-string "walk\n")
  (hp-mh-send-string "walk\n")
  (hp-mh-goto-node (car (hp-mh-parse-show-text (hp-mh-read-output)))))

(defun hp-mh-back-node ()
  "Step back in a Magma help tree walk."
  (interactive)
  ; See comment for walk-node
  (hp-mh-send-string "back\n")
  (hp-mh-send-string "back\n")
  (hp-mh-goto-node (car (hp-mh-parse-show-text (hp-mh-read-output)))))

;; These functions are basically rip-offs of the Info equivalents.
(defun hp-mh-scroll-next (arg)
  "Scroll forward in Magma help."
  (interactive "P")
  ; Are we at the end of a buffer?
  (if (pos-visible-in-window-p (point-max))
      ; Yes. Do a forward-moving thing.
      (if (eq last-command this-command)
          (progn                        ; Twice in a row means walk
            (hp-mh-walk-node)
            (setq this-command 'hp-mh-walk-node)) ; Reset last command
        ; Just once means let us know.
        (message "Hit %s again to walk to next node"
                 (key-description (event-key last-command-event))))
    ; No, scroll forward normally.
    (scroll-up arg)
    (setq this-command 'scroll-up)))

(defun hp-mh-scroll-prev (arg)
  "Scroll backward in Magma help."
  (interactive "P")
  ; Are we at the beginning of the buffer?
  (if (pos-visible-in-window-p (point-min))
      ; Yes. Do a backward-moving thing.
      (if (eq last-command this-command)
          (progn                        ; Twice in a row means step back
            (hp-mh-back-node)
            (setq this-command 'hp-mh-back-node)) ; Reset last command.
        ; Just once means let us know.
        (message "Hit %s again to walk to previous node"
                 (key-description (event-key last-command-event))))
    ; No, scroll backward normally.
    (scroll-down arg)
    (setq this-command 'scroll-down)))

(defun hp-mh-goto-node (dir &optional norecord)
  "Change the given node (absolute or relative.) Optional argument
NORECORD, if true, means don't save this jump in the history list.
Note that this function is the only entry point for changing the
current node."
  (interactive "i")                     ; We read manually
  ; Hack, because interactive doesn't know how to call a function.
  ; There is probably a better way to do this.
  (if (interactive-p)
      (setq dir (hp-mh-read-path-from-user)))
  ; Log last node
  (unless norecord
    (push (hp-mh-current-node) hp-mh-node-history-list))
  (unless (interactive-p)
    (message (concat "Going to " dir)))
  (hp-mh-send-string (concat "cd "
                             ; Ugly hack to use links in the form [+3]
                             (if (string-match "^\\[\\(.*\\)\\]$" dir)
                                 (match-string 1 dir)
                               dir)
                             "\n") t)
  ; Wait for an error message, if there is one
  (sleep-for hp-mh-sleep-period)
  (let ((outstr (hp-mh-read-output)))
    ; Check for errors
    (if (and outstr
             (string-match "does not exist" outstr))
        (progn
          (message (concat "No such node: " dir))
          ; Cancel the logging (could be better)
          (unless norecord
            (pop hp-mh-node-history-list)))
      (hp-mh-display-current-node))))

;;;; Process interface

;;; Filter function
(defun hp-mh-process-filter (proc str)
  ; Just save the output
  (setq hp-mh-last-output (concat hp-mh-last-output str)))

;;; Interface for the rest of the package
(defun hp-mh-read-output ()
  "Read the last output produced by the Magma process."
  (let ((result hp-mh-last-output))
    (setq hp-mh-last-output nil)
    result))

(defun hp-mh-send-string (str &optional nowait)
  "Send string STR to the Magma Help process. Wait for some answering
output unless NOWAIT is true. When the function returns, output will
be accessible with `hp-mh-read-output'."
  (setq hp-mh-last-output nil)
  (process-send-string hp-mh-process str)
  (unless nowait
    (if (null hp-mh-last-output)
        (accept-process-output hp-mh-process))
    ; Ugly hack, shouldn't really be here
    (sleep-for hp-mh-sleep-period)))

;;;; Output
(defun hp-mh-display-output (&optional header footer)
  "Display the last Magma output to the user."
  (with-current-buffer hp-mh-user-buffer
    (erase-buffer)
    (if header (insert-string header))
    (insert-string (hp-mh-squeeze-trailing-slash (hp-mh-read-output)))
    (if footer (insert-string footer))
    (hp-mh-color-links)
    (goto-char (point-min))))

(defun hp-mh-display-current-node ()
  "Create and display the Info-style page for the current Magma help node."
  (interactive)
  (message "Displaying...")
  (with-current-buffer hp-mh-user-buffer
    (let ((cur-node-name (hp-mh-current-node)))
      (erase-buffer)
      (insert-string (hp-mh-self-text))
      (insert-string (concat "Current node: " cur-node-name "\n"))
      (insert-string "Links:\n")
      (mapcar (lambda (x)
                (hp-cprot-insert-string-with-face x 'hp-mh-link-type-face)
                (insert-string " \n"))
              (hp-mh-get-node-children))
      (hp-cprot-insert-string-with-face ".." 'hp-mh-link-type-face)
      (insert-string "\n")
      (hp-mh-color-links)
      (goto-char (point-min))
      (message "Displaying...done"))))

(defun hp-mh-color-links ()
  "Find and mark explicit links in the Magma help page."
  (with-current-buffer hp-mh-user-buffer
    (goto-char (point-min))
    (while (re-search-forward hp-mh-explicit-link-regexp nil t)
      ; The 1+ is the non-space character at the beginning of the match.
      (set-extent-property (make-extent (1+ (match-beginning 0))
                                        (match-end 0))
                           'face 'hp-mh-link-type-face))))

;;;; Program Magma interface (parsing Magma output and such)
(defun hp-mh-current-node ()
  "Return the location of the current node in the Magma help browser."
  ; Send the request to Magma.
  (hp-mh-send-string "pwd\n")
  ; Get the output.
  (let ((outstring (hp-mh-squeeze-trailing-slash (hp-mh-read-output))))
    ; Do we understand it?
    (if (string-match hp-mh-pwd-output-regexp outstring)
        ; Yes. Return the path.
        (match-string 1 outstring)
      ; No. Signal an error.
      (signal 'hp-mh-cannot-parse-output (list "pwd" outstring)))))

(defun hp-mh-get-node-children (&optional node)
  "Get all children of the given node, or current node if NODE is nil."
  ; Send the request to Magma.
  (hp-mh-send-string (concat "ls " node "\n"))
  (let ((mystr (hp-mh-read-output)))
    ; Any children?
    (if (string-match "No children" mystr)
        ; No.
        nil
      ; Yes, parse the output
      (hp-mh-get-all-matches hp-mh-ls-output-regexp mystr 0))))

(defun hp-mh-get-path-completion (part-name pred flag)
  "Return the possible completions for PART-NAME as a Magma help path."
  ; Split apart the partial name, and figure out what the children are.
  (let* ((dirname (file-name-directory part-name))
         (children (hp-mh-get-node-children dirname))
         (child-cons-list (mapcar (lambda (x) (cons x 1)) children))
         (full-names (mapcar (lambda (x) (concat dirname x)) children))
         (fname (file-name-nondirectory part-name)))
    (cond ((equal flag nil)
           ; Complete as far as possible
           (let ((tc-out (try-completion fname child-cons-list)))
             (cond ((equal tc-out nil) nil)
                   ((equal tc-out t) t) ; XXX Perhaps concat a "/"?
                   (t (concat dirname tc-out)))))
          ((equal flag t)
           ; Give list of completions
           (all-completions part-name (mapcar (lambda (x) (cons x 1))
                                              full-names)))
          ((equal flag 'lambda)
           ; Return t or nil according to whether this is or is not
           ; a full completion.
           (if (memq part-name full-names) t nil))
          (t (message "oops...")))))

(defun hp-mh-read-path-from-user ()
  "Read a Magma help path from the user."
  (interactive)
  (completing-read "Path: " 'hp-mh-get-path-completion))

(defun hp-mh-parse-show-text (txt)
  "Receives the text of a node, e.g. what was output by `show' or `walk',
and returns a list of three elements, the first being the node path, the
second being the node type (overview, example, etc.), and the third the
node text."
  (let* ((text (hp-mh-squeeze-trailing-slash txt))
         (path-text (progn
                      (string-match "^PATH: \\(\\S-+\\)\n" text)
                      (match-string 1 text)))
         (kind-text (progn
                      (string-match "^KIND: \\(\\S-+\\)\n" text)
                      (match-string 1 text)))
         (rest-text (progn
                      (substring text
                                 (1+ (hp-mh-find-nth-match "\n" text 4))))))
    (list path-text kind-text rest-text)))

(defun hp-mh-self-text ()
  "Return the text of the current Magma help node."
  (hp-mh-send-string "show\n")
  (hp-mh-squeeze-trailing-slash (hp-mh-read-output)))

;; Final bookkeeping.
(provide 'magma-help)