Emacs Help Mode

extensions/emacs-help-mode/lem-emacs-help-mode.asd

@@ -0,0 +1,10 @@
+(in-package #:asdf-user)
+
+(defsystem "lem-emacs-help-mode"
+  :description "Emacs Style Help Keybindings for Lem"
+  :author "Robert Wess Burnett"
+  :license "MIT"
+  :depends-on ("lem/core")
+  :serial t
+  :components ((:file "main")))
+

extensions/emacs-help-mode/main.lisp

@@ -0,0 +1,54 @@
+(defpackage #:lem-emacs-help-mode
+  (:use #:cl #:lem))
+(in-package #:lem-emacs-help-mode)
+
+(defvar *previous-ctrl-h-suffix* nil)
+(defvar *previous-describe-output-override* nil)
+(defvar *ctrl-h-keymap* (make-keymap))
+
+(define-key *ctrl-h-keymap* "k" 'describe-key)
+(define-key *ctrl-h-keymap* "b" 'describe-bindings)
+(define-key *ctrl-h-keymap* "m" 'describe-mode)
+(define-key *ctrl-h-keymap* "a" 'apropos-command)
+(define-key *ctrl-h-keymap* "v" 'apropos-variable)
+
+;; TODO add describe-function command for "f"
+
+(defun enable (&optional recursed-p)
+  "Enables emacs help mode"
+  (let* ((prefixes (keymap-prefixes *global-keymap*))
+         (ctrl-h (first (parse-keyspec "C-h")))
+         (index (position ctrl-h prefixes :key #'prefix-key :test #'key-equal)))
+
+    (cond
+      (index
+       (setf *previous-ctrl-h-suffix* (prefix-suffix (nth index prefixes)))
+       (setf (prefix-suffix (nth index prefixes)) *ctrl-h-keymap*)
+       (setf *previous-describe-output-override*
+             lem-core/commands/help:*describe-output-type-override*)
+       (setf lem-core/commands/help:*describe-output-type-override* :buffer))
+      (recursed-p
+       (error "Infinite loop"))
+      (t
+       (push (make-prefix :key ctrl-h) (keymap-prefixes *global-keymap*))
+       (enable t)))))
+
+(defun disable ()
+  "Disables emacs help mode"
+  (let* ((prefixes (keymap-prefixes *global-keymap*))
+         (ctrl-h (first (parse-keyspec "C-h")))
+         (index (position ctrl-h prefixes :key #'prefix-key
+                          :test #'lem-core:key-equal)))
+    (assert index)
+    (setf (prefix-suffix (nth index prefixes)) *previous-ctrl-h-suffix*)
+    (setf *previous-ctrl-h-suffix* nil)
+    (setf lem-core/commands/help:*describe-output-type-override*
+          *previous-describe-output-override*)
+    (setf *previous-describe-output-override* nil)))
+
+(define-minor-mode emacs-help-mode
+    (:name "EHelp"
+     :description "Adds Emacs Style C-h Bindings."
+     :global t
+     :enable-hook 'enable
+     :disable-hook 'disable))

lem.asd

@@ -303,7 +303,8 @@
                "lem-living-canvas"
                "lem-tree-sitter"
                "lem-git-gutter"
-               "lem-skk-mode"))
+               "lem-skk-mode"
+               "lem-emacs-help-mode"))
 
 (defsystem "lem"
   :version "2.3.0"

src/commands/help.lisp

@@ -4,23 +4,58 @@
            :describe-bindings
            :describe-mode
            :apropos-command
+           :describe-command
+           :apropos-variable
+           :describe-variable
            :lem-version
-           :list-modes)
+           :list-modes
+           :*describe-output-type-override*)
   #+sbcl
   (:lock t))
 (in-package :lem-core/commands/help)
 
 (define-key *global-keymap* "C-x ?" 'describe-key)
 
+(declaim (type (member nil :buffer :popup :message)
+               *describe-output-type-override*))
+(defvar *describe-output-type-override* nil
+  "When non nil, describe commands will always
+   send their information to this type of output")
+
+(defmacro with-describe-output-stream
+    ((var requested-output-type &optional (buffer-name "*Description*"))
+     &body body)
+  (alexandria:with-gensyms (output-buffer)
+    `(ecase (or *describe-output-type-override* ,requested-output-type)
+       ((:message)
+        (let ((,var (make-string-output-stream)))
+          (unwind-protect
+               (progn
+                 ,@body)
+            (show-message (get-output-stream-string ,var)))))
+       ((:popup)
+        (with-pop-up-typeout-window (,var (make-buffer ,buffer-name) :erase t)
+          ,@body))
+       ((:buffer)
+        (let ((,var (make-string-output-stream)))
+          (unwind-protect
+               (progn
+                 ,@body)
+            (let ((,output-buffer (make-buffer ,buffer-name)))
+              (erase-buffer ,output-buffer)
+              (insert-string (buffer-point ,output-buffer) (get-output-stream-string ,var))
+              (pop-to-buffer ,output-buffer))))))))
+
 (define-command describe-key () ()
   "Tell what is the command associated to a keybinding."
   (show-message "describe-key: ")
   (redraw-display)
   (let* ((kseq (read-key-sequence))
          (cmd (find-keybind kseq)))
-    (show-message (format nil "describe-key: ~a ~(~a~)"
-                          (keyseq-to-string kseq)
-                          cmd))))
+    (with-describe-output-stream (s :message)
+      (format s "describe-key: ~a ~(~a~)"
+              (keyseq-to-string kseq)
+              cmd))))
 
 (defun describe-bindings-internal (s name keymap &optional first-p)
   (unless first-p
@@ -45,7 +80,7 @@
   "Describe the bindings of the buffer's current major mode."
   (let ((buffer (current-buffer))
         (firstp t))
-    (with-pop-up-typeout-window (s (make-buffer "*bindings*") :erase t)
+    (with-describe-output-stream (s :popup "*bindings*")
       (describe-bindings-internal s
                                   (mode-name (buffer-major-mode buffer))
                                   (setf firstp (mode-keymap (buffer-major-mode buffer)))
@@ -65,7 +100,7 @@
 
 (define-command list-modes () ()
   "Output all available major and minor modes."
-  (with-pop-up-typeout-window (s (make-buffer "*all-modes*") :erase t)
+  (with-describe-output-stream (s :popup "*all-modes*")
     (let ((major-modes (major-modes))
           (minor-modes (minor-modes)))
       (labels ((is-technical-mode (mode)
@@ -84,6 +119,10 @@
         (print-modes "Major modes" major-modes)
         (print-modes "Minor modes" minor-modes)))))
 
+(define-command describe-all-modes () ()
+  "Alias for list-modes"
+  (call-command 'list-modes nil))
+
 (define-command describe-mode () ()
   "Show information about current major mode and enabled minor modes."
   (let* ((buffer (current-buffer))
@@ -93,7 +132,7 @@
                                    :when (and (mode-active-p buffer mode)
                                               (not (find mode minor-modes)))
                                    :collect mode)))
-    (with-pop-up-typeout-window (s (make-buffer "*modes*") :erase t)
+    (with-describe-output-stream (s :popup "*modes*")
       (format s "Major mode is: ~A~@[ – ~A~]~%"
               (mode-name major-mode)
               (mode-description major-mode))
@@ -111,24 +150,79 @@
                   (mode-description mode)))))))
 
 (define-command apropos-command () ()
-  "Find all symbols in the running Lisp image whose names match a given string."
+  "Find all commands in the running Lisp image whose names match a given string."
   (let ((str (prompt-for-string
               "Apropos: "
               :completion-function
               (lambda (str) (completion str (all-command-names))))))
-    (with-pop-up-typeout-window (out (make-buffer "*Apropos*") :erase t)
+    (with-describe-output-stream (out :popup "*Apropos*")
       (dolist (name (all-command-names))
         (when (search str name)
           (describe (command-name (find-command name)) out))))))
 
+(define-command describe-command () ()
+  "Alias for apropos-command"
+  (call-command 'apropos-command nil))
+
+(defun lem-symbol-p (symbol)
+  (let* ((pkg (symbol-package symbol))
+         (name (package-name pkg)))
+    (string-equal "LEM" (subseq name 0 3))))
+
+(defun is-variable-p (symbol)
+  "Returns true if the symbol is a lem variable or an editor variable"
+  (or (lem/common/var:editor-variable-p (get symbol 'editor-variable))
+      (and (lem-symbol-p symbol)
+           (boundp symbol)
+           (not (constantp symbol)))))
+
+(defparameter *all-variables-cache* nil
+  "Cached list of all strings that represent variables")
+(defun all-variables ()
+  (unless *all-variables-cache*
+    (loop
+      :for pkg :in (list-all-packages)
+      :appending 
+         (loop
+           :for sym :being :the external-symbols :of (find-package pkg)
+           :when (is-variable-p sym)
+           :collect (string-downcase
+                     (format nil "~a:~a"
+                            (package-name (find-package pkg))
+                            (symbol-name sym))))
+      :into syms
+      :finally (setf *all-variables-cache* syms)))
+  *all-variables-cache*)
+
+(define-command apropos-variable () ()
+  (let* ((str (prompt-for-string 
+              "Enter Variable: "
+              :completion-function
+              (lambda (str) (completion str (all-variables))))))
+    (with-describe-output-stream (out :popup "*variable-description*")
+      ;; TODO get a better description than just describe
+      (let* ((sym (read-from-string str))
+             (editor-variable (get sym 'editor-variable)))
+        (cond
+          ((lem/common/var:editor-variable-p editor-variable)
+           (format
+            out
+            "~a is an EDITOR VARIABLE bound to the following value: ~%~%" sym)
+           (describe editor-variable out))
+          ((is-variable-p sym)
+           (describe sym out))
+          (t 
+           (format out "~a does not describe any variable" sym)))))))
+
 (define-command lem-version () ()
   "Display Lem's version."
   (let ((version (get-version-string)))
-    (show-message (princ-to-string version))))
+    (with-describe-output-stream (s :message "*Version*")
+      (format s "~a" version))))
 
 (define-command help () ()
   "Show some help."
-  (with-pop-up-typeout-window (s (make-buffer "*Help*") :erase t)
+  (with-describe-output-stream (s :popup "*Help*")
     (format s "Welcome to Lem.~&")
     (format s "You are running ~a.~&" (get-version-string))
     (format s "~%")

src/common/var.lisp

@@ -11,6 +11,7 @@
    :variable-documentation
    :find-editor-variable
    :editor-variables
+   :editor-variable-p
    :with-global-variable-value))
 (in-package :lem/common/var)
 

src/internal-packages.lisp

@@ -99,6 +99,7 @@
    :key-shift
    :key-sym
    :match-key
+   :key-equal
    :insertion-key-sym-p
    :named-key-sym-p
    :define-named-key

src/key.lisp

@@ -86,6 +86,17 @@
        (eq (key-shift key) shift)
        (equal (key-sym key) sym)))
 
+(defun key-equal (key-one key-two)
+  "Returns t if key-one == key-two, nil otherwise"
+  (match-key key-one
+             :ctrl (key-ctrl key-two)
+             :meta (key-meta key-two)
+             :super (key-super key-two)
+             :hyper (key-hyper key-two)
+             :shift (key-shift key-two)
+             :sym (key-sym key-two)))
+
+
 (defun insertion-key-sym-p (sym)
   (= 1 (length sym)))
 

src/keymap.lisp

@@ -639,4 +639,5 @@ for KEYMAP, populating and reusing the keymap's binding-cache slot."
 
 (defmacro with-special-keymap ((keymap) &body body)
   `(let ((*special-keymap* (or ,keymap *special-keymap*)))
-     ,@body))
+     ,@body))
+