euslime.el.in

;;; euslime.el ---                                 -*- lexical-binding: t; -*-

;; Copyright (C) 2018  furushchev

;; Authors:
;;   Yuki Furuta <furushchev@jsk.imi.i.u-tokyo.ac.jp>
;;   Guilherme de Campos Affonso <affonso@jsk.imi.i.u-tokyo.ac.jp>
;; Keywords: lisp

;; This program 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.

;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(add-to-list 'load-path "/opt/ros/$ENV{ROS_DISTRO}/share/emacs/site-lisp")
(add-to-list 'load-path "/opt/ros/$ENV{ROS_DISTRO}/share/emacs/site-lisp/slime")
(add-to-list 'load-path "${CMAKE_INSTALL_PREFIX}/${CATKIN_PACKAGE_SHARE_DESTINATION}/slime-repl-ansi-color")
(add-to-list 'load-path "${CMAKE_SOURCE_DIR}/slime-repl-ansi-color")

(require 'rosemacs)
(require 'slime-autoloads)
(require 'slime-repl "contrib/slime-repl.el")
(require 'slime-c-p-c "contrib/slime-c-p-c.el")
(require 'subr-x)

;; AUXILIARY FUNCTIONS
(defun remove-asdf-system-shortcuts ()
  (cl-flet ((sys? (shortcut)
              (string-match-p "system" (car (slime-repl-shortcut.names shortcut)))))
    (cl-remove-if #'sys? slime-repl-shortcut-table)))

(defun slime-apropos-symbol-package (prefix package)
  "Show apropos listing for symbols in PACKAGE including PREFIX."
  (interactive (list (read-string "SLIME Apropos: ")
                     (let ((pkg (slime-read-package-name "Package: ")))
                       (if (string= pkg "") (slime-current-package) pkg))))
  (slime-apropos prefix t package))

(defun slime-clear-screen ()
  "Move current repl line to top of the buffer"
  (interactive)
  (if (<= slime-repl-input-start-mark (point))
      (save-excursion
        (let ((recenter-positions '(top bottom)))
          (goto-char slime-repl-input-start-mark)
          (recenter-top-bottom)))
    (recenter-top-bottom)))

(defun slime-swap-to-output-buffer ()
  "Select the output buffer and display it as a full window."
  (interactive)
  (switch-to-buffer (slime-output-buffer))
  (delete-other-windows)
  (goto-char (point-max)))

(defun euslime-maybe-set-package ()
  (with-current-buffer (slime-output-buffer)
    (if (slime-repl-shortcut-eval `(swank:set-package ""))
        (slime-repl-set-package ""))))

;; INTERRUPT
;; Override to always dispatch and insert new prompt when needed
(defun slime-interrupt ()
  "Interrupt Lisp."
  (interactive)
  (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))
  (sleep-for 0.1)  ;; wait for emacs :set-package response
  (euslime-maybe-set-package)
  (message nil))

;; LOAD FILE
(defcustom euslime-file-completion-function 'completing-read
  "The completion function to be used for EusLisp file completion"
  :type 'function)

(setq euslime-file-completor
  (lambda (str pred action)
    (let* ((ros-file-prefix "package://")
           (pos (string-match-p ros-file-prefix str)))
      (if pos
          (let* ((inhibit-message t)  ;; avoid unwanted advertising
                 (ros-str (substring str (+ pos (length ros-file-prefix))))
                 (res (funcall ros-package-completor ros-str pred action)))
            (if (stringp res)
                (concat ros-file-prefix res)
              res))
        (funcall 'read-file-name-internal str pred action)))))

(defun euslime-read-euslisp-file-name (prompt &optional predicate require-match initial &rest args)
  (apply euslime-file-completion-function
         prompt euslime-file-completor
         predicate require-match initial
         args))

(defun euslime-load-file-and-tags-with-transcript (filename)
  (slime-repl-add-to-input-history
   (prin1-to-string `(slime::load-file-and-tags ,filename)))
  (run-hooks 'slime-transcript-start-hook)
  (slime-rex () (`(swank:load-file ,filename))
    ((:ok value)
     (run-hooks 'slime-transcript-stop-hook)
     (when (consp value)
       (let ((inhibit-message t))
         (dolist (val value)
           (euslime-load-tags val))))
     (slime-display-eval-result t))
    ((:abort condition)
     (run-hooks 'slime-transcript-stop-hook)
     (message "Evaluation aborted on %s." condition))))

(defun euslime-load-file (filename)
  "Load the EusLisp file FILENAME."
  (interactive (list
                (euslime-read-euslisp-file-name
                 "Load file: " nil nil
                 (if (buffer-file-name) (buffer-file-name)))))
  (euslime-load-file-and-tags-with-transcript filename))


;; SHORTCUT COMMANDS
;; Override to load tags as well
(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "load" "cl")
  (:handler (lambda (filename)
              (interactive (list (euslime-read-euslisp-file-name "Load file: ")))
              (slime-save-some-lisp-buffers)
              (if slime-euslisp-mode
                  (euslime-load-file-and-tags-with-transcript filename)
                (slime-repl-shortcut-eval-async
                 `(swank:compile-file-if-needed
                   ,(slime-to-lisp-filename filename) t)
                 #'slime-compilation-finished))))
  (:one-liner "Compile (if neccessary) and load a lisp file."))

;; Override to inherit the buffer-local `slime-repl-shortcut-table'
(defun slime-list-repl-short-cuts ()
  (interactive)
  (let ((mode (if slime-euslisp-mode 'slime-euslisp-mode)))
    (slime-with-popup-buffer ((slime-buffer-name :repl-help) :mode mode)
      (let ((table (cl-sort (cl-copy-list slime-repl-shortcut-table) #'string<
                            :key (lambda (x)
                                   (car (slime-repl-shortcut.names x))))))
        (save-excursion
          (dolist (shortcut table)
            (let ((names (slime-repl-shortcut.names shortcut)))
              (insert (pop names)) ;; first print the "full" name
              (when names
                ;; we also have aliases
                (insert " (aka ")
                (while (cdr names)
                  (insert (pop names) ", "))
                (insert (car names) ")"))
              (when (slime-repl-shortcut.one-liner shortcut)
                (insert "\n     " (slime-repl-shortcut.one-liner shortcut)))
              (insert "\n"))))))))

;; Override to use LISP package when in EusLisp mode
(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!")
  (:handler (lambda (name value)
              (interactive (list (slime-read-symbol-name "Name (symbol): " t)
                                 (slime-read-from-minibuffer "Value: " "*")))
              (let ((prefix (if slime-euslisp-mode "lisp" "cl")))
                (insert "(" prefix ":" "defparameter " name " " value
                        " \"REPL generated global variable.\")"))
              (slime-repl-send-input t)))
  (:one-liner "Define a new global, special, variable."))

;; Override to avoid trailing newlines upon consecutive execution
;; The same could be attained by setting `slime-repl-history-trim-whitespaces',
;; but this causes color change in the prompt-string in Euslisp mode
(defslime-repl-shortcut slime-repl-resend ("resend-form")
  (:handler (lambda ()
              (interactive)
              (insert (car slime-repl-input-history))
              (slime-repl-send-input t)))
  (:one-liner "Resend the last form."))

;; ROS shortcuts
;; ros master and other environment variables are copied from the original terminal
;; this shortcut is for changing the ros master after starting the euslime session
(defslime-repl-shortcut slime-repl-rossetmaster ("rossetmaster")
  (:handler (lambda (host port)
              (interactive (list (slime-read-from-minibuffer "Host: " "localhost")
                                 (slime-read-from-minibuffer "Port: " "11311")))
              (let ((port-number (cl-parse-integer port)))
                ;; set for current session
                (when slime-euslisp-mode
                  (insert "(slime::rossetmaster \"" host "\" " port ")")
                  (slime-repl-send-input t))
                ;; set for future sessions
                (ros-set-master-uri host port-number))))
  (:one-liner "Set ROS_MASTER_URI"))

;; simplified version of the original script at
;; https://github.com/jsk-ros-pkg/jsk_common/blob/master/jsk_tools/env-hooks/99.jsk_tools.sh
;; don't test for connectivity with rosmaster; simply set the env variables
(defslime-repl-shortcut slime-repl-rossetip ("rossetip")
  (:handler (lambda (address)
              (interactive (list
                            (slime-read-from-minibuffer "Address: "
                              (string-trim-right
                               (shell-command-to-string
                                "LANG=C ip -o -4 a | grep -E \"^[0-9]+: (eth|wl|en|lo)[0-9]*\" | tail -n1 | sed -e 's@^.*inet *\\([0-9\\.]*\\).*$@\\1@g'")))))
              ;; set for current session
              (when slime-euslisp-mode
                (insert "(slime::rossetip \"" address "\")")
                (slime-repl-send-input t))
              ;; set for future sessions
              (setenv "ROS_IP" address)
              (setenv "ROS_HOSTNAME" address)
              (message (format "Set ROS_IP and ROS_HOSTNAME to %s" address))))
  (:one-liner "Set ROS_IP and ROS_HOSTNAME"))


;; COMPLETION FUNCTIONS
;; Override to allow `package://' completion and avoid full paths
(defun slime-maybe-complete-as-filename ()
   "If point is at a string starting with \", complete it as filename.
 Return nil if point is not at filename."
   (when (save-excursion (re-search-backward "\"[^ \t\n]+\\="
                                            (max (point-min)
                                                 (- (point) 1000)) t))
     (let ((match (match-string 0))
           (pos1 (match-beginning 0))
           (pos2 (point)))
       (if (and slime-euslisp-mode (string-match-p "\"package://" match))
           ;; complete as ROS file
           (completion-in-region (+ pos1 11) pos2 ros-package-completor)
         ;; complete as standard filename
         (let ((comint-completion-addsuffix '("/" . "\"")))
           (if (and (boundp 'slime-when-complete-filename-expand)
                    (not slime-when-complete-filename-expand))
               ;; complete with local-path
               (progn
                 (setq default-directory (slime-eval `(swank:default-directory)))
                 (comint-dynamic-complete-filename))
             ;; complete with absolute path
             (comint-replace-by-expanded-filename))))
       t)))

;; Override to avoid regular symbol completions when keywords do not match
(cl-defun slime-contextual-completions (beg end)
  "Return a list of completions of the token from BEG to END in the
current buffer."
  (let ((token (buffer-substring-no-properties beg end)))
    (cond
     ((and (< beg (point-max))
           (string= (buffer-substring-no-properties beg (1+ beg)) ":"))
      ;; Contextual keyword completion
      (let ((completions 
             (slime-completions-for-keyword token
                                            (save-excursion 
                                              (goto-char beg)
                                              (slime-parse-form-upto-point)))))
        (when (or slime-euslisp-mode (cl-first completions))
          ;; Always return when in euslisp mode
          (cl-return-from slime-contextual-completions completions))
        ;; If no matching keyword was found, do regular symbol
        ;; completion.
        ))
     ((and (>= (length token) 2)
           (string= (cl-subseq token 0 2) "#\\"))
      ;; Character name completion
      (cl-return-from slime-contextual-completions
        (slime-completions-for-character token))))
    ;; Regular symbol completion
    (slime-completions token)))

(defun slime-set-minibuffer-completion ()
  (let ((buf (other-buffer (current-buffer) t)))
    (if (local-variable-if-set-p 'slime-complete-symbol-function buf)
        (setq-local slime-complete-symbol-function
                    (buffer-local-value 'slime-complete-symbol-function buf)))))

;; HOOKS
;; Support ansi-colors in popup buffers
(add-hook 'slime-popup-buffer-mode-hook
          (lambda () (ansi-color-apply-on-region (point-min) (point-max))))

;; Wrap lines on slime debugger
(add-hook 'sldb-mode-hook
          (lambda () (visual-line-mode nil)))

;; Use find-tag when `tags-table-list' is set
(add-hook 'slime-edit-definition-hooks
          (lambda (name where)
            (when (string= (ignore-errors (slime-connection-name)) "euslisp")
              (let ((name-lst
                     (slime-eval `(swank:find-tag-name-for-emacs ,name ,(slime-lisp-package)))))
                (if name-lst
                    (slime-edit-definition-cont (apply #'euslime-find-definitions name-lst)
                                                (car name-lst) where)
                  ;; Search for any match if symbol is not found
                  (let ((euslime-match-function 'tag-any-match-p))
                    (slime-edit-definition-cont (euslime-find-definitions name)
                                                name where)))))))

;; Set custom recenter function
(add-hook 'slime-repl-mode-hook
          (lambda ()
            (when slime-use-slime-clear-screen
              (define-key slime-repl-mode-map "\C-l" 'slime-clear-screen)

              ;; Override to avoid recentering when the output doesn't reach end of buffer
              (defun slime-repl-show-maximum-output ()
                "Put the end of the buffer at the bottom of the window when necessary."
                (when (eobp)
                  (let ((win (if (eq (window-buffer) (current-buffer))
                                 (selected-window)
                               (get-buffer-window (current-buffer) t))))
                    (when win
                      (with-selected-window win
                        (set-window-point win (point-max))
                        ;; (recenter -1)
                        ))))))))

;; Use `eulsime-load-file' on slime-mode when connected to euslisp
(add-hook 'slime-connected-hook
          (lambda ()
            (let ((conn (slime-current-connection)))
              (if (equal "euslisp" (ignore-errors (slime-connection-name conn)))
                  (define-key slime-mode-map (concat (kbd "C-c") (kbd "C-l"))
                    'euslime-load-file)))))

;; Add `slime-switch-to-output-buffer' shortcuts
(add-hook 'slime-connected-hook
          (lambda ()
            (let ((prefix (slime-euslisp--doc-map-prefix)))
              (define-key slime-mode-map (concat prefix (kbd "C-o"))
                'slime-switch-to-output-buffer)
              (define-key slime-mode-map (concat prefix (kbd "o"))
                'slime-swap-to-output-buffer))))

;; DEFINE MINOR MODE
(defun slime-euslisp--doc-map-prefix ()
  (concat
   (car (rassoc '(slime-prefix-map) slime-parent-bindings))
   (car (rassoc '(slime-doc-map) slime-prefix-bindings))))

(define-minor-mode slime-euslisp-mode
  "Toggle Euslisp SLIME mode."
  :lighter " eus"
  :keymap (let ((prefix (slime-euslisp--doc-map-prefix)))
            `((,(concat prefix (kbd "C-p")) . slime-apropos-symbol-package)
              (,(concat prefix "p") . slime-apropos-symbol-package)
              (,(concat (kbd "C-c") (kbd "C-l")) . euslime-load-file)))
              ;; (,(kbd "M-,") . tags-loop-continue)
              ;; (,(kbd "M-.") . find-tag)))
  ;; Use simple-completions rather than fuzzy-completions
  (setq-local slime-complete-symbol-function 'slime-complete-symbol*)
  (add-hook 'minibuffer-setup-hook 'slime-set-minibuffer-completion)
  (setq-local slime-complete-symbol*-fancy nil)
  ;; Remove unsupported ASDF commands
  (setq-local slime-repl-shortcut-table (remove-asdf-system-shortcuts))
  ;; Inhibit queries when tags change
  (setq tags-revert-without-query t)
  ;; Keep history record in a different file
  (setq-local slime-repl-history-file "~/.euslime-history.eld")
  (slime-repl-safe-load-history)
  ;; Start Message
  (when (called-interactively-p 'interactive)
    (message "Euslisp SLIME mode %s."
             (if slime-euslisp-mode "enabled" "disabled"))))

(provide 'euslime)