ambevar-dotfiles/.local/share/common-lisp/source/ambrevar/emacs.lisp

(uiop:define-package ambrevar/emacs
  (:documentation "Communication with Emacs")
  (:use #:common-lisp)
  (:use #:trivia)
  (:import-from #:serapeum #:export-always)
  (:import-from #:ambrevar/shell))
(in-package ambrevar/emacs)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
  (trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum))

;; TODO: Rename `emacs-readable-value'?
(defmethod emacs-value ((s symbol))
  s)

(defmethod emacs-value ((s string))
  s)

(defmethod emacs-value ((object t))
  (write-to-string object))

(defmethod emacs-value ((c complex))
  (write-to-string c))

(defmethod emacs-value ((n number))
  n)

(defmethod emacs-value ((l list))
  (mapcar #'emacs-value l))

;; (defmethod emacs-value ((l vector))
;;   (mapcar #'emacs-value l))

(defmethod emacs-value ((l list))
  (mapcar #'emacs-value l))
;; TODO: How do we pass timestamps to Emacs?  Floating points work, but how do
;; we make the distinction between a timestamp and a random float?
;; (defmethod emacs-value ((l local-time:timestamp))
;;   "Return the the floating point number of seconds since Epoch.
;; Can be passed to Emacs' `float-time'."
;;   (format nil "~f"
;;           (+ (local-time:timestamp-to-unix l)
;;              (/ (local-time:timestamp-microsecond l) 1000000d0))))

;; TODO: Should `header' return strings?
(defmethod header ((object standard-object))
  (mapcar (alex:compose #'str:capitalize #'symbol-name) (mopu:slot-names object)))

;; TODO: Support structures.
(defmethod header ((table hash-table))
  (alex:hash-table-keys table))

(defmethod header ((seq sequence))
  (cond
    ((trivial-types:property-list-p seq)
     (sera:plist-keys seq))
    ;; TODO: Fix predicate for alists.
    ((trivial-types:association-list-p seq)
     (mapcar #'first seq))
    (t
     (alex:iota (length seq)))))

(defmethod ->list ((object standard-object))
  (mapcar (lambda (slot-name)
            ;; list or cons?
            ;; (list slot-name)
            (emacs-value (slot-value object slot-name)))
          ;; TODO: Slot order?
          (mopu:slot-names object)))

(defmethod ->list ((table hash-table))
  (alex:hash-table-values table))

(defmethod ->list ((seq sequence))
  (cond
    ((trivial-types:property-list-p seq)
     (sera:plist-values seq))
    ;; TODO: Fix predicate for alists.
    ((trivial-types:association-list-p seq)
     (mapcar #'rest seq))
    (t
     (coerce seq 'list))))

;; TODO: Add helper to print list of objects / structs / plist / alist to an Emacs tabulated-mode buffer.

(export-always 'with-emacs-eval)
(defmacro with-emacs-eval (&body body)
  "Evaluate BODY (s-expressions) with `emacsclient'.
Example:

  (with-emacs-eval
    (switch-to-buffer (get-buffer-create \"foobar\"))
    (insert \"Hello\"))"
  `(let ((*package* (find-package :ambrevar/emacs)))
     (cmd:cmd "emacsclient" "-e"
              (let ((*print-case* :downcase))
                (format nil "'~s'" '(progn ,@body))))))

(defun %emacs-eval (caller &rest s-exp)
  "See `emacs-eval'."
  (let ((*package* (find-package :ambrevar/emacs)))
    (funcall caller "emacsclient" "-e"
             (list
              (let ((*print-case* :downcase))
                (format nil "~s" `(progn
                                      ,@s-exp)))))))

(export-always 'emacs-eval)
(defun emacs-eval (&rest s-exp)
  "Evaluate (quoted) s-expressions with `emacsclient'.
Example:

  (let ((buffer \"foobar\")
        (content \" world!\"))
    (emacs-eval
      `(switch-to-buffer (get-buffer-create ,buffer))
      `(insert ,conent)))"
  (apply #'%emacs-eval #'cmd:cmd s-exp))

(export-always 'emacs-$eval)
(defun emacs-$eval (&rest s-exp)
  "Like `emacs-eval' but return a string."
  (apply #'%emacs-eval #'cmd:$cmd s-exp))

(export-always 'emacs-eval>)
(defun emacs-eval> (&rest s-exp)
  "Like `emacs-eval' but return a stream."
  (apply #'%emacs-eval #'ambrevar/shell:cmd> s-exp))

(export-always 'write-emacs-buffer)
(defun write-emacs-buffer (buffer-or-name thing)
  "Write THING to Emacs' BUFFER-OR-NAME using `write-to-string'.
This means string double quotes are included.
See `princ-emacs-buffer'."
  (emacs-eval
   `(with-current-buffer (get-buffer-create ,buffer-or-name)
      (insert ,(write-to-string thing)))))

(export-always 'princ-emacs-buffer)
(defun princ-emacs-buffer (buffer-or-name thing)
  "Like `write-emacs-buffer' but using `princ-to-string'."
  (emacs-eval
    `(with-current-buffer (get-buffer-create ,buffer-or-name)
       (insert ,(princ-to-string thing)))))

(export-always 'emspect)
(defun emspect (&rest things)
  "Inspect THINGS with Emacs.
Require the `clinspect' library."
  ;; TODO: Allow customizing column sorters, width, formatters.
  (emacs-eval
   `(clinspect ',(header (first things))
               ',(mapcar #'->list things))))

(defun emacs-unescape (string)
  "Since Emacsclient returns escaped strings, return the string in a form
understood by Common Lisp."
  (if (<= 2 (length string))
      (str:replace-all "\\n" (string #\newline)
                       (subseq string 1 (1- (length string))))
      string))

(export-always 'emacs-buffer-string)
(defun emacs-buffer-string (buffer-or-name)
  "Return Emacs' BUFFER-OR-NAME content as a string."
  (emacs-unescape
   (emacs-$eval
    `(with-current-buffer (get-buffer-create ,buffer-or-name)
       (buffer-substring-no-properties (point-min) (point-max) )))))

;; (export-always 'emacs-buffer-stream)
(defun emacs-buffer-stream (buffer-or-name)
  "Return Emacs' BUFFER-OR-NAME content as a stream."
  (make-string-input-stream (emacs-buffer-string buffer-or-name)))

(export-always 'with-emacs-buffer-stream)
(defmacro with-emacs-buffer-stream ((in buffer-or-name) &body body)
  "Evaluate BODY with IN bound to an input stream of the Emacs' BUFFER-OR-NAME."
  `(with-input-from-string (,in (emacs-buffer-string ,buffer-or-name))
     ,@body))

;; TODO: Make Emacs buffer output stream.