1608 lines
65 KiB
EmacsLisp
1608 lines
65 KiB
EmacsLisp
;;; ess-utils.el --- General Emacs utility functions used by ESS
|
||
|
||
;; Copyright (C) 1998--2010 A.J. Rossini, Richard M. Heiberger, Martin
|
||
;; Maechler, Kurt Hornik, Rodney Sparapani, and Stephen Eglen.
|
||
;; Copyright (C) 2011--2017 A.J. Rossini, Richard M. Heiberger, Martin Maechler,
|
||
;; Kurt Hornik, Rodney Sparapani, Stephen Eglen and Vitalie Spinu.
|
||
|
||
;; Author: Martin Maechler <maechler@stat.math.ethz.ch>
|
||
;; Created: 9 Sept 1998
|
||
;; Maintainer: ESS-core <ESS-core@r-project.org>
|
||
|
||
;; This file is part of ESS (Emacs Speaks Statistics).
|
||
|
||
;; This file 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 2, or (at your option)
|
||
;; any later version.
|
||
|
||
;; This file 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.
|
||
|
||
;; A copy of the GNU General Public License is available at
|
||
;; http://www.r-project.org/Licenses/
|
||
|
||
;;; Code:
|
||
|
||
(eval-when-compile
|
||
(require 'tramp)
|
||
;; We can't use cl-lib whilst supporting Emacs <= 24.2 users
|
||
(with-no-warnings (require 'cl)))
|
||
|
||
|
||
;;*;; Internal ESS tools and variables
|
||
|
||
(defvar ess-lisp-directory
|
||
(directory-file-name (file-name-directory (locate-library "ess-site")))
|
||
"Directory containing ess-site.el(c) and other ESS lisp files.")
|
||
|
||
(defvar ess-etc-directory nil
|
||
"Location of the ESS etc/ directory.
|
||
The ESS etc directory stores various auxillary files that are useful
|
||
for ESS, such as icons.")
|
||
|
||
(defvar ess-etc-directory-list
|
||
'("../etc/ess/" "../etc/" "../../etc/ess/" "./etc/")
|
||
"List of directories, relative to `ess-lisp-directory', to search for etc.")
|
||
|
||
(while (and (listp ess-etc-directory-list) (consp ess-etc-directory-list))
|
||
(setq ess-etc-directory
|
||
(expand-file-name (concat ess-lisp-directory "/"
|
||
(car ess-etc-directory-list))))
|
||
(if (file-directory-p ess-etc-directory)
|
||
(setq ess-etc-directory-list nil)
|
||
(setq ess-etc-directory nil)
|
||
(setq ess-etc-directory-list (cdr ess-etc-directory-list))
|
||
(when (null ess-etc-directory-list)
|
||
(beep 0) (beep 0)
|
||
(message (concat
|
||
"ERROR:ess-site.el:ess-etc-directory\n"
|
||
"Relative to ess-lisp-directory, one of the following must exist:\n"
|
||
"../etc/ess, ../etc, ../../etc/ess or ./etc"))
|
||
(sit-for 4))))
|
||
|
||
(defun ess-message (format-string &rest args)
|
||
"Shortcut for \\[message] only if `ess-show-load-messages' is non-nil."
|
||
(when (bound-and-true-p ess-show-load-messages)
|
||
(message format-string args)))
|
||
|
||
|
||
;;*;; elisp tools
|
||
|
||
(defun ess-goto-line (line)
|
||
(save-restriction
|
||
(widen)
|
||
(goto-char (point-min))
|
||
(forward-line (1- line))))
|
||
|
||
(defun ess-line-end-position (&optional N)
|
||
"return the 'point' at the end of N lines. N defaults to 1, i.e., current line."
|
||
(save-excursion
|
||
(end-of-line N)
|
||
(point)))
|
||
|
||
(defun ess-search-except (regexp &optional except backward)
|
||
"Search for a regexp, store as match 1, optionally ignore
|
||
strings that match exceptions."
|
||
(interactive)
|
||
|
||
(let ((continue t) (exit nil))
|
||
|
||
(while continue
|
||
(if (or (and backward (search-backward-regexp regexp nil t))
|
||
(and (not backward) (search-forward-regexp regexp nil t)))
|
||
(progn
|
||
(setq exit (match-string 1))
|
||
(setq continue (and except (string-match except exit)))
|
||
(if continue (setq exit nil)))
|
||
;;else
|
||
(setq continue nil))
|
||
)
|
||
|
||
exit))
|
||
|
||
(defun ess-save-and-set-local-variables ()
|
||
"If buffer was modified, save file and set Local Variables if defined.
|
||
Return t if buffer was modified, nil otherwise."
|
||
(interactive)
|
||
|
||
(let ((ess-temp-point (point))
|
||
(ess-temp-return-value (buffer-modified-p)))
|
||
;; if buffer has changed, save buffer now (before potential revert)
|
||
(if ess-temp-return-value (save-buffer))
|
||
|
||
;; If Local Variables are defined, update them now
|
||
;; since they may have changed since the last revert
|
||
;; (save-excursion
|
||
(beginning-of-line -1)
|
||
(save-match-data
|
||
(if (search-forward "End:" nil t) (revert-buffer t t)))
|
||
;; save-excursion doesn't save point in the presence of a revert
|
||
;; so you need to do it yourself
|
||
(goto-char ess-temp-point)
|
||
|
||
ess-temp-return-value))
|
||
|
||
(defun ess-get-file-or-buffer (file-or-buffer)
|
||
"Return file-or-buffer if it is a buffer; otherwise return the buffer
|
||
associated with the file which must be qualified by it's path; if the
|
||
buffer does not exist, return nil."
|
||
(interactive)
|
||
|
||
(if file-or-buffer
|
||
(if (bufferp file-or-buffer) file-or-buffer
|
||
(find-buffer-visiting file-or-buffer))))
|
||
|
||
(defun ess-set-local-variables (alist &optional file-or-buffer)
|
||
"Set local variables from ALIST in current buffer; if file-or-buffer
|
||
is specified, perform action in that buffer."
|
||
(interactive)
|
||
(if file-or-buffer (set-buffer (ess-get-file-or-buffer file-or-buffer)))
|
||
|
||
(mapcar (lambda (pair)
|
||
(make-local-variable (car pair))
|
||
(set (car pair) (eval (cdr pair))))
|
||
alist))
|
||
|
||
(defun ess-clone-local-variables (from-file-or-buffer
|
||
&optional to-file-or-buffer)
|
||
"Clone local variables from one buffer to another buffer."
|
||
(interactive)
|
||
(ess-set-local-variables
|
||
(ess-sas-create-local-variables-alist from-file-or-buffer)
|
||
to-file-or-buffer))
|
||
|
||
(defun ess-return-list (ess-arg)
|
||
"Given an item, if it is a list return it, else return item in a list."
|
||
(if (listp ess-arg) ess-arg (list ess-arg)))
|
||
|
||
;; Copyright (C) 1994 Simon Marshall.
|
||
;; Author: Simon Marshall <Simon.Marshall@mail.esrin.esa.it>
|
||
;; LCD Archive Entry:
|
||
;; unique|Simon Marshall|Simon.Marshall@mail.esrin.esa.it|
|
||
;; Functions and commands to uniquify lists or buffer text (cf. sort).
|
||
;; 23-Apr-1994|1.00|~/packages/unique.el.Z|
|
||
;;
|
||
;; MM: renamed from 'unique' to 'ess-unique', then
|
||
(defun ess-uniq (list predicate)
|
||
"Uniquify LIST, stably, deleting elements using PREDICATE.
|
||
Return the list with subsequent duplicate items removed by side effects.
|
||
PREDICATE is called with an element of LIST and a list of elements from LIST,
|
||
and should return the list of elements with occurrences of the element removed.
|
||
This function will work even if LIST is unsorted. See also `ess-uniq-list'."
|
||
(let ((list list))
|
||
(while list
|
||
(setq list (setcdr list (funcall predicate (car list) (cdr list))))))
|
||
list)
|
||
|
||
(defun ess-uniq-list (items)
|
||
"Delete all duplicate entries in ITEMS list, calling `ess-uniq'."
|
||
(ess-uniq items 'delete))
|
||
|
||
(defun ess-flatten-list (&rest list)
|
||
"Take the arguments and flatten them into one long list.
|
||
Drops 'nil' entries."
|
||
;; Taken from lpr.el
|
||
;; `lpr-flatten-list' is defined here (copied from "message.el" and
|
||
;; enhanced to handle dotted pairs as well) until we can get some
|
||
;; sensible autoloads, or `flatten-list' gets put somewhere decent.
|
||
|
||
;; (ess-flatten-list '((a . b) c (d . e) (f g h) i . j))
|
||
;; => (a b c d e f g h i j)
|
||
(ess-flatten-list-1 list))
|
||
|
||
(defun ess-flatten-list-1 (list)
|
||
(cond
|
||
((null list) (list))
|
||
((consp list)
|
||
(append (ess-flatten-list-1 (car list))
|
||
(ess-flatten-list-1 (cdr list))))
|
||
(t (list list))))
|
||
|
||
(defun ess-delete-blank-lines ()
|
||
"Convert 2 or more lines of white space into one."
|
||
(interactive)
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(save-match-data
|
||
(while (search-forward-regexp "^[ \t]*\n[ \t]*\n" nil t)
|
||
;;(goto-char (match-beginning 0))
|
||
(delete-blank-lines)))))
|
||
|
||
;; Parse a line into its constituent parts (words separated by
|
||
;; whitespace). Return a list of the words.
|
||
;; Taken from rlogin.el, from the comint package, from XEmacs 20.3.
|
||
(defun ess-line-to-list-of-words (line)
|
||
(if (listp line)
|
||
line
|
||
(let ((list nil)
|
||
(posn 0))
|
||
;; (match-data (match-data)))
|
||
(while (string-match "[^ \t\n]+" line posn)
|
||
(setq list (cons (substring line (match-beginning 0) (match-end 0))
|
||
list))
|
||
(setq posn (match-end 0)))
|
||
(store-match-data (match-data))
|
||
(nreverse list))))
|
||
|
||
|
||
;;*;; System
|
||
|
||
(defun ess-revert-wisely ()
|
||
"Revert from disk if file and buffer last modification times are different."
|
||
(interactive)
|
||
|
||
; whether or not a revert is needed, force load local variables
|
||
; for example, suppose that you change the local variables and then
|
||
; save the file, a revert is unneeded, but a force load is
|
||
(hack-local-variables)
|
||
|
||
(if (not (verify-visited-file-modtime (current-buffer))) (progn
|
||
(let ((ess-temp-store-point (point)))
|
||
(revert-buffer t t)
|
||
(goto-char ess-temp-store-point))
|
||
t)
|
||
nil))
|
||
|
||
(defun ess-kermit-get (&optional ess-file-arg ess-dir-arg)
|
||
"Get a file with Kermit. WARNING: Experimental! From your *shell*
|
||
buffer, start kermit and then log in to the remote machine. Open
|
||
a file that starts with `ess-kermit-prefix'. From that buffer,
|
||
execute this command. It will retrieve a file from the remote
|
||
directory that you specify with the same name, but without the
|
||
`ess-kermit-prefix'."
|
||
|
||
(interactive)
|
||
|
||
;; (save-match-data
|
||
(let ((ess-temp-file (if ess-file-arg ess-file-arg (buffer-name)))
|
||
(ess-temp-file-remote-directory ess-dir-arg))
|
||
|
||
(if (string-equal ess-kermit-prefix (substring ess-temp-file 0 1))
|
||
(progn
|
||
;; I think there is a bug in the buffer-local variable handling in GNU Emacs 21.3
|
||
;; Setting ess-kermit-remote-directory every time is somehow resetting it to the
|
||
;; default on the second pass. So, here's a temporary work-around. It will fail
|
||
;; if you change the default, so maybe this variable should not be customizable.
|
||
;; In any case, there is also trouble with local variables in XEmacs 21.4.9 and
|
||
;; 21.4.10. XEmacs 21.4.8 is fine.
|
||
(if ess-temp-file-remote-directory
|
||
(setq ess-kermit-remote-directory ess-temp-file-remote-directory)
|
||
|
||
(if (string-equal "." ess-kermit-remote-directory)
|
||
(setq ess-kermit-remote-directory (read-string "Remote directory to transfer file from: "
|
||
ess-kermit-remote-directory))))
|
||
|
||
(setq ess-temp-file-remote-directory ess-kermit-remote-directory)
|
||
;; (setq ess-temp-file (substring ess-temp-file (match-end 0)))
|
||
(ess-sas-goto-shell)
|
||
(insert "cd " ess-temp-file-remote-directory "; " ess-kermit-command " -s "
|
||
(substring ess-temp-file 1) " -a " ess-temp-file)
|
||
(comint-send-input)
|
||
;; (insert (read-string "Press Return to connect to Kermit: " nil nil "\C-\\c"))
|
||
;; (comint-send-input)
|
||
;; (insert (read-string "Press Return when Kermit is ready to recieve: " nil nil
|
||
;; (concat "receive ]" ess-sas-temp-file)))
|
||
;; (comint-send-input)
|
||
;; (insert (read-string "Press Return when transfer is complete: " nil nil "c"))
|
||
;; (comint-send-input)
|
||
(insert (read-string "Press Return when shell is ready: "))
|
||
(comint-send-input)
|
||
(switch-to-buffer (find-buffer-visiting ess-temp-file))
|
||
(ess-revert-wisely)
|
||
))))
|
||
|
||
(defun ess-kermit-send ()
|
||
"Send a file with Kermit. WARNING: Experimental! From
|
||
a file that starts with `ess-kermit-prefix',
|
||
execute this command. It will transfer this file to the remote
|
||
directory with the same name, but without the `ess-kermit-prefix'."
|
||
|
||
(interactive)
|
||
|
||
;; (save-match-data
|
||
(let ((ess-temp-file (expand-file-name (buffer-name)))
|
||
(ess-temp-file-remote-directory nil))
|
||
|
||
(if (string-equal ess-kermit-prefix (substring (file-name-nondirectory ess-temp-file) 0 1))
|
||
(progn
|
||
;; I think there is a bug in the buffer-local variable handling in GNU Emacs 21.3
|
||
;; Setting ess-kermit-remote-directory every time is somehow resetting it to the
|
||
;; default on the second pass. Here's a temporary work-around. It will fail
|
||
;; if you change the default, so maybe this variable should not be customizable.
|
||
;; In any case, there is also trouble with local variables in XEmacs 21.4.9 and
|
||
;; 21.4.10. XEmacs 21.4.8 is fine.
|
||
(if (string-equal "." ess-kermit-remote-directory)
|
||
(setq ess-kermit-remote-directory (read-string "Remote directory to transfer file to: "
|
||
ess-kermit-remote-directory)))
|
||
|
||
(setq ess-temp-file-remote-directory ess-kermit-remote-directory)
|
||
|
||
;; (setq ess-temp-file (substring ess-temp-file (match-end 0)))
|
||
(ess-sas-goto-shell)
|
||
(insert "cd " ess-temp-file-remote-directory "; " ess-kermit-command " -a "
|
||
(substring (file-name-nondirectory ess-temp-file) 1) " -g " ess-temp-file)
|
||
(comint-send-input)
|
||
;; (insert (read-string "Press Return to connect to Kermit: " nil nil "\C-\\c"))
|
||
;; (comint-send-input)
|
||
;; (insert (read-string "Press Return when Kermit is ready to recieve: " nil nil
|
||
;; (concat "receive ]" ess-sas-temp-file)))
|
||
;; (comint-send-input)
|
||
;; (insert (read-string "Press Return when transfer is complete: " nil nil "c"))
|
||
;; (comint-send-input)
|
||
(insert (read-string "Press Return when shell is ready: "))
|
||
(comint-send-input)
|
||
(switch-to-buffer (find-buffer-visiting ess-temp-file))
|
||
(ess-revert-wisely)
|
||
))))
|
||
|
||
|
||
(defun ess-find-exec (ess-root-arg ess-root-dir)
|
||
"Given a root directory and the root of an executable file name,
|
||
find it's full name and path, if it exists, anywhere in the sub-tree."
|
||
(let* ((ess-tmp-dirs (directory-files ess-root-dir t "^[^.]"))
|
||
(ess-tmp-return (ess-find-exec-completions ess-root-arg ess-root-dir))
|
||
(ess-tmp-dir nil))
|
||
|
||
(while ess-tmp-dirs
|
||
(setq ess-tmp-dir (car ess-tmp-dirs)
|
||
ess-tmp-dirs (cdr ess-tmp-dirs))
|
||
(if (file-accessible-directory-p ess-tmp-dir)
|
||
(setq ess-tmp-return
|
||
(nconc ess-tmp-return
|
||
(ess-find-exec ess-root-arg ess-tmp-dir)))))
|
||
ess-tmp-return))
|
||
|
||
(defun ess-find-exec-completions (ess-root-arg &optional ess-exec-dir)
|
||
"Given the root of an executable file name, find all possible completions.
|
||
Search for the executables in ESS-EXEC-DIR (which defaults to
|
||
`exec-path' if no value is given)."
|
||
(let* ((ess-exec-path
|
||
(if ess-exec-dir (ess-return-list ess-exec-dir) exec-path))
|
||
(ess-tmp-exec nil)
|
||
(ess-tmp-path-count (length ess-exec-path))
|
||
(ess-tmp-dir nil)
|
||
(ess-tmp-files nil)
|
||
(ess-tmp-file nil))
|
||
|
||
(while ess-exec-path
|
||
(setq ess-tmp-dir (car ess-exec-path)
|
||
ess-exec-path (cdr ess-exec-path))
|
||
(when
|
||
(and (> (length ess-tmp-dir) 0)
|
||
(file-accessible-directory-p ess-tmp-dir))
|
||
;; the first test above excludes "" from exec-path, which can be
|
||
;; problematic with Tramp.
|
||
(setq ess-tmp-files
|
||
(file-name-all-completions ess-root-arg ess-tmp-dir))
|
||
|
||
(while ess-tmp-files
|
||
(setq ess-tmp-file
|
||
(concat (file-name-as-directory ess-tmp-dir)
|
||
(car ess-tmp-files))
|
||
ess-tmp-files (cdr ess-tmp-files))
|
||
(if (and (file-executable-p ess-tmp-file)
|
||
(not (file-directory-p ess-tmp-file)))
|
||
;; we have found a possible executable, so keep it.
|
||
(setq ess-tmp-exec
|
||
(nconc ess-tmp-exec (list ess-tmp-file)))))))
|
||
ess-tmp-exec))
|
||
|
||
(defun ess-drop-non-directories (file-strings)
|
||
"Drop all entries that do not \"look like\" directories."
|
||
(ess-flatten-list (mapcar 'file-name-directory file-strings)))
|
||
|
||
(defun ess--parent-dir (path n)
|
||
"Return Nth parent of PATH."
|
||
(let ((opath path))
|
||
(while (and path (> n 0))
|
||
(setq path (file-name-directory (directory-file-name opath)))
|
||
(if (equal path opath)
|
||
(setq path nil)
|
||
(setq opath path
|
||
n (1- n))))
|
||
path))
|
||
|
||
|
||
;;*;; Interaction with inferiors
|
||
|
||
(defmacro ess-when-new-input (time-var &rest body)
|
||
"BODY is evaluate only if the value of procss variable TIME-VAR
|
||
is bigger than the time of the last user input (stored in
|
||
'last-eval' process variable). TIME-VAR is the name of the
|
||
process variable which holds the access time. See the code for
|
||
`ess-synchronize-dirs' and `ess-cache-search-list'.
|
||
|
||
Returns nil when no current process, or process is busy, or
|
||
time-var > last-eval. Otherwise, execute BODY and return the last
|
||
value.
|
||
|
||
If BODY is executed, set process variable TIME-VAR
|
||
to (current-time).
|
||
|
||
Variable *proc* is bound to the current process during the
|
||
evaluation of BODY.
|
||
|
||
Should be used in `ess-idle-timer-functions' which call the
|
||
process to avoid excessive requests.
|
||
"
|
||
(declare (indent 1) (debug t))
|
||
`(with-ess-process-buffer 'no-error
|
||
(let ((le (process-get *proc* 'last-eval))
|
||
(tv (process-get *proc* ',time-var)))
|
||
(when (and (or (null tv) (null le) (time-less-p tv le))
|
||
(not (process-get *proc* 'busy)))
|
||
(let ((out (progn ,@body)))
|
||
(process-put *proc* ',time-var (current-time))
|
||
out)))))
|
||
|
||
(defmacro ess-execute-dialect-specific (command &optional prompt &rest args)
|
||
"Execute dialect specific command.
|
||
|
||
-- If command is nil issue warning 'Not available for dialect X'
|
||
-- If command is a elisp function, execute it with ARGS
|
||
-- If a string starting with 'http' or 'www', browse with `browse-url',
|
||
otherwise execute the command in inferior process.
|
||
-- If a string, interpret as a command to subprocess, and
|
||
substitute ARGS with `(format ,command ,@args).
|
||
|
||
When PROMPT is non-nil ask the user for a string value and
|
||
prepend the response to ARGS.
|
||
|
||
If prompt is a string just pass it to `read-string'. If a list, pass it
|
||
to `ess-completing-read'.
|
||
"
|
||
`(if (null ,command)
|
||
(message "Not implemented for dialect %s" ess-dialect)
|
||
(let* ((com (if (symbolp ,command)
|
||
(symbol-function ,command)
|
||
,command))
|
||
(prompt ',prompt)
|
||
(resp (and prompt
|
||
(if (stringp prompt)
|
||
(read-string prompt)
|
||
(apply 'ess-completing-read prompt))))
|
||
(args (append (list resp) ',args)))
|
||
(cond ((functionp com)
|
||
(apply com args))
|
||
((and (stringp com)
|
||
(string-match "^\\(http\\|www\\)" com))
|
||
(setq com (apply 'format com args))
|
||
(require 'browse-url)
|
||
(browse-url com))
|
||
((stringp com)
|
||
(unless (string-match "\n$" com)
|
||
(setq com (concat com "\n")))
|
||
(setq com (apply 'format com args))
|
||
(ess-eval-linewise com))
|
||
(t
|
||
(error "Argument COMMAND must be either a function or a string"))))))
|
||
|
||
(defun ess--inject-code-from-file (file)
|
||
;; this is different from ess-load-file
|
||
(let ((content (with-temp-buffer
|
||
(insert-file-contents file)
|
||
(buffer-string))))
|
||
(when (string= ess-dialect "R")
|
||
;; don't detect intermediate prompts
|
||
(setq content (concat "{" content "}\n")))
|
||
(ess-command content)))
|
||
|
||
(defcustom ess-idle-timer-interval 1
|
||
"Number of idle seconds to wait before running function in
|
||
`ess-idle-timer-functions'."
|
||
:group 'ess)
|
||
|
||
(defvar ess-idle-timer-functions nil
|
||
"A list of functions to run each `ess-idle-timer-interval' idle seconds.
|
||
|
||
If your function calls the process, you better use
|
||
`ess-when-new-input' to wrap your call. If you call the
|
||
subprocess please respect `ess-can-eval-in-background' variable.
|
||
|
||
These functions are run with `run-hooks'. Use `add-hook' to add
|
||
symbols to this variable.
|
||
|
||
Most likely you will need a local hook. Then you should specify
|
||
the LOCAL argument to `add-hook' and initialise it in
|
||
`ess-mode-hook' or `ess-post-run-hook', or one of the more
|
||
specialised hooks `ess-r-post-run-hook',`ess-stata-post-run-hook'
|
||
etc.
|
||
")
|
||
|
||
(defun ess--idle-timer-function nil
|
||
"Internal function executed by `ess--idle-timer'"
|
||
;; (while-no-input
|
||
(run-hooks 'ess-idle-timer-functions))
|
||
|
||
(require 'timer)
|
||
(defvar ess--idle-timer
|
||
(run-with-idle-timer ess-idle-timer-interval 'repeat 'ess--idle-timer-function)
|
||
"Timer used to run `ess-idle-timer-functions'.")
|
||
|
||
|
||
;;*;; Emacs Integration
|
||
|
||
;;;*;;; Menus
|
||
|
||
(defun ess--generate-eval-visibly-submenu (menu)
|
||
'(["yes" (lambda () (interactive) (setq ess-eval-visibly t))
|
||
:style radio :enable t :selected (eq ess-eval-visibly t)]
|
||
["nowait" (lambda () (interactive) (setq ess-eval-visibly 'nowait))
|
||
:style radio :enable t :selected (eq ess-eval-visibly 'nowait) ]
|
||
["no" (lambda () (interactive) (setq ess-eval-visibly nil))
|
||
:style radio :enable t :selected (eq ess-eval-visibly nil) ]))
|
||
|
||
;;;*;;; Font Lock
|
||
|
||
(defun ess--extract-default-fl-keywords (keywords)
|
||
"Extract the t-keywords from `ess-font-lock-keywords'."
|
||
(delq nil (mapcar (lambda (c)
|
||
(when (cdr c) (symbol-value (car c))))
|
||
(if (symbolp keywords)
|
||
(symbol-value keywords)
|
||
keywords))))
|
||
|
||
(defun ess-font-lock-toggle-keyword (keyword)
|
||
(interactive
|
||
(list (intern (ess-completing-read
|
||
"Keyword to toggle"
|
||
(mapcar (lambda (el) (symbol-name (car el)))
|
||
(symbol-value ess-font-lock-keywords))
|
||
nil t))))
|
||
(let* ((kwds (symbol-value (if (eq major-mode 'ess-mode)
|
||
ess-font-lock-keywords
|
||
inferior-ess-font-lock-keywords)))
|
||
(kwd (assoc keyword kwds)))
|
||
(unless kwd (error "Keyword %s was not found in (inferior-)ess-font-lock-keywords list" keyword))
|
||
(if (cdr kwd)
|
||
(setcdr kwd nil)
|
||
(setcdr kwd t))
|
||
(let ((mode major-mode)
|
||
(dialect ess-dialect)
|
||
(fld (ess--extract-default-fl-keywords kwds)))
|
||
;; refresh font-lock defaults in all necessary buffers
|
||
(mapc (lambda (b)
|
||
(with-current-buffer b
|
||
(when (and (eq major-mode mode)
|
||
(eq ess-dialect dialect))
|
||
(setcar font-lock-defaults fld)
|
||
(font-lock-refresh-defaults))))
|
||
(buffer-list)))))
|
||
|
||
(defun ess--generate-font-lock-submenu (menu)
|
||
"Internal, used to generate ESS font-lock submenu"
|
||
(append (mapcar (lambda (el)
|
||
`[,(symbol-name (car el))
|
||
(lambda () (interactive)
|
||
(ess-font-lock-toggle-keyword ',(car el)))
|
||
:style toggle
|
||
:enable t
|
||
:selected ,(cdr el)])
|
||
(cond ((eq major-mode 'ess-mode)
|
||
(symbol-value ess-font-lock-keywords))
|
||
((eq major-mode 'inferior-ess-mode)
|
||
(symbol-value inferior-ess-font-lock-keywords))))
|
||
(list "-----"
|
||
["Save to custom" (lambda () (interactive)
|
||
(let ((kwd (if (eq major-mode 'ess-mode)
|
||
ess-font-lock-keywords
|
||
inferior-ess-font-lock-keywords)))
|
||
(customize-save-variable kwd (symbol-value kwd)))) t])))
|
||
|
||
|
||
;;;*;;; External modes
|
||
|
||
(defun ess-completing-read (prompt collection &optional predicate
|
||
require-match initial-input hist def)
|
||
"Read a string in the minibuffer, with completion.
|
||
Use `ido-completing-read' if IDO interface is present, or fall
|
||
back on classical `completing-read' otherwise. Meaning of
|
||
arguments is as in `completing-read' (PROMPT is automatically
|
||
suffixed with ': ' and (default %s) when needed). If HIST
|
||
is null use `ess--completing-hist' as history.
|
||
|
||
See also `ess-use-ido'."
|
||
(let ((use-ido (and ess-use-ido (featurep 'ido))))
|
||
(setq hist (or hist 'ess--completing-hist))
|
||
(when (and def (not use-ido)) ;; ido places in front and highlights the default
|
||
(setq prompt (format "%s(default %s)" prompt def)))
|
||
(setq prompt (concat prompt ": "))
|
||
(if use-ido
|
||
(let ((reset-ido (and use-ido (not ido-mode))) ;people not using ido but having it)
|
||
(ido-current-directory nil)
|
||
(ido-directory-nonreadable nil)
|
||
(ido-directory-too-big nil)
|
||
(ido-context-switch-command 'ignore)
|
||
(ido-enable-flex-matching ess-ido-flex-matching) ;it's fast and useful, may be get into options
|
||
(ido-choice-list (copy-sequence collection)) ;ido removes the match (reported)
|
||
sel)
|
||
(unwind-protect
|
||
(progn
|
||
(ido-init-completion-maps)
|
||
(add-hook 'minibuffer-setup-hook 'ido-minibuffer-setup)
|
||
(add-hook 'choose-completion-string-functions 'ido-choose-completion-string)
|
||
(setq sel (ido-read-internal 'list prompt hist def require-match initial-input))
|
||
(when hist ;; ido does not push into hist the whole match if C-SPC or RET is used (reported)
|
||
(unless (string= sel (car (symbol-value hist)))
|
||
(set hist (cons sel (symbol-value hist))))))
|
||
(when reset-ido
|
||
(remove-hook 'minibuffer-setup-hook 'ido-minibuffer-setup)
|
||
(remove-hook 'choose-completion-string-functions 'ido-choose-completion-string)))
|
||
sel)
|
||
;; else usual completion
|
||
(when (and (featurep 'xemacs) ;; xemacs workaround
|
||
(not (listp (car collection))))
|
||
(setq collection (mapcar 'list collection)))
|
||
(completing-read prompt collection predicate require-match initial-input hist def))))
|
||
|
||
(defun ess-load-extras (&optional inferior)
|
||
"Load all the extra features depending on custom settings."
|
||
|
||
(let ((mode (if inferior 'inferior-ess-mode 'ess-mode))
|
||
(isR (string-match "^R" ess-dialect)))
|
||
|
||
;; auto-complete
|
||
(when (and (boundp 'ac-sources)
|
||
(if inferior
|
||
(eq ess-use-auto-complete t)
|
||
ess-use-auto-complete))
|
||
(add-to-list 'ac-modes mode)
|
||
;; files should be in front; ugly, but needed
|
||
(when ess-ac-sources
|
||
(setq ac-sources
|
||
(delq 'ac-source-filename ac-sources))
|
||
(mapc (lambda (el) (add-to-list 'ac-sources el))
|
||
ess-ac-sources)
|
||
(add-to-list 'ac-sources 'ac-source-filename)))
|
||
|
||
;; company
|
||
(when (and (boundp 'company-backends)
|
||
(if inferior
|
||
(eq ess-use-company t)
|
||
ess-use-company))
|
||
(when ess-company-backends
|
||
(set (make-local-variable 'company-backends)
|
||
(copy-list (append ess-company-backends company-backends)))
|
||
(delq 'company-capf company-backends)))
|
||
|
||
;; eldoc)
|
||
(require 'eldoc)
|
||
(when (and ess-eldoc-function ;; if mode provide this, it suports eldoc
|
||
(or (and (not inferior) ess-use-eldoc)
|
||
(and inferior (eq ess-use-eldoc t))))
|
||
(when (> eldoc-idle-delay 0.4) ;; default is too slow for paren help
|
||
(set (make-local-variable 'eldoc-idle-delay) 0.1))
|
||
(set (make-local-variable 'eldoc-documentation-function) ess-eldoc-function)
|
||
(turn-on-eldoc-mode))
|
||
|
||
;; tracebug
|
||
(when (and ess-use-tracebug inferior isR)
|
||
(ess-tracebug 1))))
|
||
|
||
(defmacro ess--execute-electric-command (map &optional prompt wait exit-form &rest args)
|
||
"Execute single-key comands defined in MAP till a key is pressed which is not part of map.
|
||
|
||
Return the value of the lastly executed command.
|
||
|
||
Single-key input commands are those that once executed do not
|
||
requre the prefix command for subsequent invocation.
|
||
|
||
PROMPT is passed to `read-event'.
|
||
|
||
If WAIT is t, wait for next input and ignore the keystroke which
|
||
triggered the command.
|
||
|
||
Each command in map should accept one at least one argument, the
|
||
most recent event (as read by `read-event'). ARGS are the
|
||
supplementary arguments passed to the commands.
|
||
|
||
EXIT-FORM should be supplied for a more refined control of the
|
||
read-even loop. The loop is exited when EXIT-FORM evaluates to
|
||
t. See examples in the tracebug code.
|
||
"
|
||
;;VS[09-06-2013]: check: it seems that set-temporary-overlay-map is designed
|
||
;;for this type of things; see also repeat.el package.
|
||
`(let* ((ev last-command-event)
|
||
(command (lookup-key ,map (vector ev)))
|
||
out exit )
|
||
(if (not (or ,wait command))
|
||
(message "%s is undefined" (key-description (this-command-keys)))
|
||
(unless ,wait
|
||
(setq out (and command (funcall command ev ,@args))))
|
||
(while (and (not exit)
|
||
(setq command
|
||
(lookup-key ,map
|
||
(vector (setq ev (read-event ,prompt))))))
|
||
(setq out (funcall command ev ,@args))
|
||
(sleep-for .01)
|
||
(setq exit ,exit-form))
|
||
(unless exit ;; push only if an event triggered the exit
|
||
(push ev unread-command-events))
|
||
out)))
|
||
|
||
(defvar ess-build-tags-command nil
|
||
"Command passed to generate tags.
|
||
|
||
If nil, `ess-build-tags-for-directory' uses the mode's imenu
|
||
regexpresion. Othersiwe, it should be a string with two %s
|
||
formats: one for directory and another for the output file.")
|
||
|
||
;;;*;;; Emacs itself
|
||
|
||
(defun ess-yank-cleaned-commands ()
|
||
"Yank and strip the code, leaving only (R/S/Lsp/..) commands.
|
||
Deletes any lines not beginning with a prompt, and then removes
|
||
the prompt from those lines that remain.
|
||
|
||
Invoke this command with C-u C-u C-y."
|
||
(setq yank-window-start (window-start))
|
||
(let ((beg (point)))
|
||
(push-mark beg)
|
||
(setq this-command t)
|
||
(insert-for-yank (current-kill 0))
|
||
(ess-transcript-clean-region beg (point) nil)
|
||
(if (eq (point) beg)
|
||
(message "No commands found"))
|
||
(if (eq this-command t)
|
||
(setq this-command 'yank))
|
||
))
|
||
|
||
(defun ess-yank (&optional ARG)
|
||
"With double prefix (C-u C-u) call `ess-yank-cleaned-commands"
|
||
(interactive "*P")
|
||
(if (equal '(16) ARG)
|
||
(ess-yank-cleaned-commands)
|
||
(let* ((remapped (command-remapping 'yank (point)))
|
||
(command (cond ((eq remapped 'ess-yank) 'yank)
|
||
((null remapped) 'yank)
|
||
(t remapped))))
|
||
(funcall command ARG))))
|
||
|
||
(put 'ess-yank 'delete-selection 'yank)
|
||
|
||
(defun ess-build-tags-for-directory (dir tagfile)
|
||
"Ask for directory and tag file and build tags for current dialect.
|
||
|
||
If the current language defines `ess-build-tags-command' use it
|
||
and ask the subprocess to build the tags. Otherwise use imenu
|
||
regexp and call find .. | etags .. in a shell command. You must
|
||
have 'find' and 'etags' programs installed.
|
||
|
||
Use M-. to navigate to a tag. M-x `visit-tags-table' to
|
||
append/replace the currently used tag table.
|
||
|
||
If prefix is given, force tag generation based on imenu. Might be
|
||
useful when different language files are also present in the
|
||
directory (.cpp, .c etc)."
|
||
(interactive "DDirectory to tag:
|
||
GTags file (default TAGS): ")
|
||
(when (or (eq (length (file-name-nondirectory tagfile)) 0)
|
||
(file-directory-p tagfile))
|
||
(setq tagfile (concat (file-name-as-directory tagfile) "TAGS")))
|
||
;; emacs find-tags doesn't play well with remote TAG files :(
|
||
(when (file-remote-p tagfile)
|
||
(require 'tramp)
|
||
(setq tagfile (with-parsed-tramp-file-name tagfile foo foo-localname)))
|
||
(when (file-remote-p dir)
|
||
(setq dir (with-parsed-tramp-file-name dir foo foo-localname)))
|
||
(if (and ess-build-tags-command (null current-prefix-arg))
|
||
(ess-eval-linewise (format ess-build-tags-command dir tagfile))
|
||
;; else generate from imenu
|
||
(unless (or imenu-generic-expression ess-imenu-generic-expression) ;; need both!!
|
||
(error "No ess-tag-command found, and no imenu-generic-expression defined"))
|
||
(let* ((find-cmd
|
||
(format "find %s -type f -size 1M \\( -regex \".*\\.\\(cpp\\|jl\\|[RsrSch]\\(nw\\)?\\)$\" \\)" dir))
|
||
(regs (delq nil (mapcar (lambda (l)
|
||
(if (string-match "'" (cadr l))
|
||
nil ;; remove for time being
|
||
(format "/%s/\\%d/"
|
||
(replace-regexp-in-string "/" "\\/" (nth 1 l) t)
|
||
(nth 2 l))))
|
||
imenu-generic-expression)))
|
||
(tags-cmd (format "etags -o %s --regex='%s' -" tagfile
|
||
(mapconcat 'identity regs "' --regex='"))))
|
||
(message "Building tags: %s" tagfile)
|
||
;; (dbg (format "%s | %s" find-cmd tags-cmd))
|
||
(when (= 0 (shell-command (format "%s | %s" find-cmd tags-cmd)))
|
||
(message "Building tags .. ok!")))))
|
||
|
||
|
||
;;;*;;; System
|
||
|
||
;; trying different viewers; thanks to an original patch for
|
||
;; ess-swv.el from Leo <sdl@web.de> :
|
||
(defun ess-get-ps-viewer ()
|
||
"Get external PostScript viewer to be used from ESS.
|
||
Use `ess-ps-viewer-pref' when that is executably found by \\[executable-find].
|
||
Otherwise try a list of fixed known viewers."
|
||
(file-name-nondirectory
|
||
(or (and ess-ps-viewer-pref ; -> ./ess-custom.el
|
||
(executable-find ess-ps-viewer-pref))
|
||
(executable-find "gv")
|
||
(executable-find "evince")
|
||
(executable-find "kghostview"))))
|
||
|
||
(defun ess-get-pdf-viewer ()
|
||
"Get external PDF viewer to be used from ESS.
|
||
Use `ess-pdf-viewer-pref' when that is executably found by \\[executable-find].
|
||
Otherwise try a list of fixed known viewers.
|
||
"
|
||
(let ((viewer (or ess-pdf-viewer-pref
|
||
;; (and (stringp ess-pdf-viewer-pref) ; -> ./ess-custom.el
|
||
;; (executable-find ess-pdf-viewer-pref))
|
||
(executable-find "evince")
|
||
(executable-find "kpdf")
|
||
(executable-find "okular")
|
||
(executable-find "xpdf")
|
||
(executable-find "acroread")
|
||
(executable-find "xdg-open")
|
||
;; this one is wrong, (ok for time being as it is used only in swv)
|
||
(car (ess-get-words-from-vector
|
||
"getOption(\"pdfviewer\")\n"))
|
||
)))
|
||
(when (stringp viewer)
|
||
(setq viewer (file-name-nondirectory viewer)))
|
||
viewer))
|
||
|
||
|
||
;;*;; UI
|
||
|
||
(defvar ess-current-region-overlay
|
||
(let ((overlay (make-overlay (point) (point))))
|
||
(overlay-put overlay 'face 'highlight)
|
||
overlay)
|
||
"The overlay for highlighting currently evaluated region or line.")
|
||
|
||
(defun ess-blink-region (start end)
|
||
(when ess-blink-region
|
||
(move-overlay ess-current-region-overlay start end)
|
||
(run-with-timer ess-blink-delay nil
|
||
(lambda ()
|
||
(delete-overlay ess-current-region-overlay)))))
|
||
|
||
(defun ess-deactivate-mark ()
|
||
(cond ((and (featurep 'evil) evil-mode)
|
||
(when (evil-visual-state-p)
|
||
(evil-normal-state)))
|
||
((fboundp 'deactivate-mark)
|
||
(deactivate-mark))))
|
||
|
||
;; SJE: 2009-01-30 -- this contribution from
|
||
;; Erik Iverson <iverson@biostat.wisc.edu>
|
||
|
||
(defun ess-tooltip-show-at-point (text xo yo)
|
||
"Show a tooltip displaying 'text' at (around) point, xo and yo are x-
|
||
and y-offsets for the toolbar from point."
|
||
(let (
|
||
(fx (frame-parameter nil 'left))
|
||
(fy (frame-parameter nil 'top))
|
||
(fw (frame-pixel-width))
|
||
(fh (frame-pixel-height))
|
||
frame-left frame-top my-x-offset my-y-offset)
|
||
|
||
;; The following comment was found before code looking much like that
|
||
;; of frame-left and frame-top below in the file
|
||
;; tooltip-help.el. I include it here for acknowledgement, and I did observe
|
||
;; the same behavior with the Emacs window maximized under Windows XP.
|
||
|
||
;; -----original comment--------
|
||
;; handles the case where (frame-parameter nil 'top) or
|
||
;; (frame-parameter nil 'left) return something like (+ -4).
|
||
;; This was the case where e.g. Emacs window is maximized, at
|
||
;; least on Windows XP. The handling code is "shamelessly
|
||
;; stolen" from cedet/speedbar/dframe.el
|
||
;; (contributed by Andrey Grigoriev)
|
||
|
||
(setq frame-left (if (not (consp fx))
|
||
fx
|
||
(if (eq (car fx) '-)
|
||
(- (x-display-pixel-width) (car (cdr fx)) fw)
|
||
(car (cdr fx)))))
|
||
|
||
(setq frame-top (if (not (consp fy))
|
||
fy
|
||
(if (eq (car fy) '-)
|
||
(- (x-display-pixel-height) (car (cdr fy)) fh)
|
||
(car (cdr fy)))))
|
||
|
||
;; calculate the offset from point, use xo and yo to adjust to preference
|
||
(setq my-x-offset (+ (car(window-inside-pixel-edges))
|
||
(car(posn-x-y (posn-at-point)))
|
||
frame-left xo))
|
||
|
||
(setq my-y-offset (+ (cadr(window-inside-pixel-edges))
|
||
(cdr(posn-x-y (posn-at-point)))
|
||
frame-top yo))
|
||
|
||
(let ((tooltip-frame-parameters
|
||
(cons (cons 'top my-y-offset)
|
||
(cons (cons 'left my-x-offset)
|
||
tooltip-frame-parameters))))
|
||
(tooltip-show text))
|
||
))
|
||
|
||
(defun ess-select-frame-set-input-focus (frame)
|
||
"Select FRAME, raise it, and set input focus, if possible.
|
||
Copied almost verbatim from gnus-utils.el (but with test for mac added)."
|
||
(cond ((featurep 'xemacs)
|
||
(raise-frame frame)
|
||
(select-frame frame)
|
||
(focus-frame frame))
|
||
;; The function `select-frame-set-input-focus' won't set
|
||
;; the input focus under Emacs 21.2 and X window system.
|
||
;;((fboundp 'select-frame-set-input-focus)
|
||
;; (defalias 'gnus-select-frame-set-input-focus
|
||
;; 'select-frame-set-input-focus)
|
||
;; (select-frame-set-input-focus frame))
|
||
(t
|
||
(raise-frame frame)
|
||
(select-frame frame)
|
||
(cond ((and
|
||
(memq window-system '(x mac))
|
||
(fboundp 'x-focus-frame))
|
||
(x-focus-frame frame))
|
||
((eq window-system 'w32)
|
||
(w32-focus-frame frame)))
|
||
(when focus-follows-mouse
|
||
(set-mouse-position frame (1- (frame-width frame)) 0)))))
|
||
|
||
(defun ess-do-auto-fill ()
|
||
"This is the same as \\[do-auto-fill] in GNU emacs 21.3, with one major
|
||
difference: if we could not find a suitable place to break the line,
|
||
we simply do not break it (instead of breaking after the first word)."
|
||
(let (fc justify bol give-up
|
||
(fill-prefix fill-prefix))
|
||
(if (or (not (setq justify (current-justification)))
|
||
(null (setq fc (current-fill-column)))
|
||
(and (eq justify 'left)
|
||
(<= (current-column) fc))
|
||
(save-excursion (beginning-of-line)
|
||
(setq bol (point))
|
||
(and auto-fill-inhibit-regexp
|
||
(looking-at auto-fill-inhibit-regexp))))
|
||
nil ;; Auto-filling not required
|
||
(if (memq justify '(full center right))
|
||
(save-excursion (unjustify-current-line)))
|
||
|
||
;; Choose a fill-prefix automatically.
|
||
(if (and adaptive-fill-mode
|
||
(or (null fill-prefix) (string= fill-prefix "")))
|
||
(let ((prefix
|
||
(fill-context-prefix
|
||
(save-excursion (backward-paragraph 1) (point))
|
||
(save-excursion (forward-paragraph 1) (point)))))
|
||
(and prefix (not (equal prefix ""))
|
||
(setq fill-prefix prefix))))
|
||
|
||
(while (and (not give-up) (> (current-column) fc))
|
||
;; Determine where to split the line.
|
||
(let* (after-prefix
|
||
(fill-point
|
||
(let ((opoint (point))
|
||
bounce
|
||
(first t))
|
||
(save-excursion
|
||
(beginning-of-line)
|
||
(setq after-prefix (point))
|
||
(and fill-prefix
|
||
(looking-at (regexp-quote fill-prefix))
|
||
(setq after-prefix (match-end 0)))
|
||
(move-to-column (1+ fc))
|
||
;; Move back to the point where we can break the line.
|
||
;; We break the line between word or
|
||
;; after/before the character which has character
|
||
;; category `|'. We search space, \c| followed by
|
||
;; a character, or \c| following a character. If
|
||
;; not found, place the point at beginning of line.
|
||
(while (or first
|
||
;; If this is after period and a single space,
|
||
;; move back once more--we don't want to break
|
||
;; the line there and make it look like a
|
||
;; sentence end.
|
||
(and (not (bobp))
|
||
(not bounce)
|
||
sentence-end-double-space
|
||
(save-excursion (forward-char -1)
|
||
(and (looking-at "\\. ")
|
||
(not (looking-at "\\. ")))))
|
||
(and (not (bobp))
|
||
(not bounce)
|
||
fill-nobreak-predicate
|
||
(funcall fill-nobreak-predicate)))
|
||
(setq first nil)
|
||
(re-search-backward "[ \t]\\|\\c|.\\|.\\c|\\|^")
|
||
;; If we find nowhere on the line to break it,
|
||
;; do not break it. Set bounce to t
|
||
;; so we will not keep going in this while loop.
|
||
(if (<= (point) after-prefix)
|
||
(setq bounce t)
|
||
(if (looking-at "[ \t]")
|
||
;; Break the line at word boundary.
|
||
(skip-chars-backward " \t")
|
||
;; Break the line after/before \c|.
|
||
(forward-char 1))))
|
||
(if enable-multibyte-characters
|
||
;; If we are going to break the line after or
|
||
;; before a non-ascii character, we may have
|
||
;; to run a special function for the charset
|
||
;; of the character to find the correct break
|
||
;; point.
|
||
(if (not (and (eq (charset-after (1- (point))) 'ascii)
|
||
(eq (charset-after (point)) 'ascii)))
|
||
(fill-find-break-point after-prefix)))
|
||
|
||
;; Let fill-point be set to the place where we end up.
|
||
;; But move back before any whitespace here.
|
||
(skip-chars-backward " \t")
|
||
(point)))))
|
||
|
||
;; See whether the place we found is any good.
|
||
(if (save-excursion
|
||
(goto-char fill-point)
|
||
(and (not (bolp))
|
||
;; There is no use breaking at end of line.
|
||
(not (save-excursion (skip-chars-forward " ") (eolp)))
|
||
;; It is futile to split at the end of the prefix
|
||
;; since we would just insert the prefix again.
|
||
(not (and after-prefix (<= (point) after-prefix)))
|
||
;; Don't split right after a comment starter
|
||
;; since we would just make another comment starter.
|
||
(not (and comment-start-skip
|
||
(let ((limit (point)))
|
||
(beginning-of-line)
|
||
(and (re-search-forward comment-start-skip
|
||
limit t)
|
||
(eq (point) limit)))))))
|
||
;; Ok, we have a useful place to break the line. Do it.
|
||
(let ((prev-column (current-column)))
|
||
;; If point is at the fill-point, do not `save-excursion'.
|
||
;; Otherwise, if a comment prefix or fill-prefix is inserted,
|
||
;; point will end up before it rather than after it.
|
||
(if (save-excursion
|
||
(skip-chars-backward " \t")
|
||
(= (point) fill-point))
|
||
(funcall comment-line-break-function t)
|
||
(save-excursion
|
||
(goto-char fill-point)
|
||
(funcall comment-line-break-function t)))
|
||
;; Now do justification, if required
|
||
(if (not (eq justify 'left))
|
||
(save-excursion
|
||
(end-of-line 0)
|
||
(justify-current-line justify nil t)))
|
||
;; If making the new line didn't reduce the hpos of
|
||
;; the end of the line, then give up now;
|
||
;; trying again will not help.
|
||
(if (>= (current-column) prev-column)
|
||
(setq give-up t)))
|
||
;; No good place to break => stop trying.
|
||
(setq give-up t))))
|
||
;; Justify last line.
|
||
(justify-current-line justify t t)
|
||
t)))
|
||
|
||
|
||
;;*;; Syntax
|
||
|
||
(defun ess-containing-sexp-position ()
|
||
(cadr (syntax-ppss)))
|
||
|
||
(defun ess-code-end-position ()
|
||
"Like (line-end-position) but stops at comments"
|
||
(save-excursion
|
||
(goto-char (1+ (line-end-position)))
|
||
(forward-comment -1)
|
||
(point)))
|
||
|
||
;; FIXME: The following function pattern stuff is specific to R but is
|
||
;; used throughout ESS
|
||
(defvar ess-r-set-function-start
|
||
;; [MGAR].. <=> {setMethod(), set[Group]Generic(), setAs(), setReplaceMethod()}
|
||
;; see also set-S4-exp in ess-r-function-pattern below
|
||
"^set[MGAR][GMa-z]+\\s-?(")
|
||
|
||
(defvar ess-function-pattern nil ; in R set to ess-r-function-pattern
|
||
"Regexp to match the beginning of a function in S buffers.")
|
||
|
||
(defvar ess-r-symbol-pattern
|
||
"\\(\\sw\\|\\s_\\)"
|
||
"The regular expression for matching an R symbol")
|
||
|
||
(defvar ess-r-name-pattern
|
||
(concat "\\(" ess-r-symbol-pattern "+\\|\\(`\\).+`\\)")
|
||
"The regular expression for matching a R name.")
|
||
|
||
(let* ((Q "\\s\"") ; quote
|
||
(repl "\\(<-\\)?") ; replacement (function)
|
||
(Sym-0 "\\(\\sw\\|\\s_\\)") ; symbol
|
||
(Symb (concat Sym-0 "+"))
|
||
(xSymb "[^ \t\n\"']+") ;; (concat "\\[?\\[?" Sym-0 "*")); symbol / [ / [[ / [symbol / [[symbol
|
||
;; FIXME: allow '%foo%' but only when quoted; don't allow [_0-9] at beg.
|
||
(_or_ "\\)\\|\\(") ; OR
|
||
(space "\\(\\s-\\|\n\\)*") ; white space
|
||
|
||
(part-1 (concat
|
||
"\\(" ;;--------outer Either-------
|
||
"\\(\\(" ; EITHER
|
||
Q xSymb Q ; any function name between quotes
|
||
_or_
|
||
"\\(^\\|[ ]\\)" Symb ; (beginning of name) + ess-r-symbol-pattern
|
||
"\\)\\)")) ; END EITHER OR
|
||
|
||
(set-S4-exp
|
||
(concat
|
||
"^set\\(As\\|Method\\|Generic\\|GroupGeneric\\|ReplaceMethod\\)(" ; S4 ...
|
||
Q xSymb Q "," space
|
||
;; and now often `` signature(......), : ''
|
||
".*" ;; <<< FIXME ???
|
||
))
|
||
|
||
(part-2 (concat
|
||
"\\|" ;;--------outer Or ---------
|
||
set-S4-exp
|
||
"\\)" ;;--------end outer Either/Or-------
|
||
|
||
"\\(" space "\\s<.*\\s>\\)*" ; whitespace, comment
|
||
;; FIXME: in principle we should skip 'definition *= *' here
|
||
space "function\\s-*(" ; whitespace, function keyword, parenthesis
|
||
)))
|
||
|
||
(defvar ess-r-function-pattern
|
||
(concat part-1
|
||
"\\s-*\\(<-\\|=\\)" ; whitespace, assign
|
||
part-2)
|
||
"The regular expression for matching the beginning of an R function.")
|
||
|
||
(defvar ess-s-function-pattern
|
||
(concat part-1
|
||
"\\s-*\\(<-\\|_\\|=\\)" ; whitespace, assign (incl. "_")
|
||
part-2)
|
||
"The regular expression for matching the beginning of an S function."))
|
||
|
||
|
||
(defvar ess--funname.start nil)
|
||
|
||
(defun ess--funname.start (&optional look-back)
|
||
"If inside a function call, return (FUNNAMME . START) where
|
||
FUNNAME is a function name found before ( and START is where
|
||
FUNNAME starts.
|
||
|
||
LOOK-BACK is a number of characters to look back; defaults to
|
||
2000. As the search might get quite slow for files with thousands
|
||
of lines.
|
||
|
||
Also store the cons in 'ess--funname.start for potential use
|
||
later."
|
||
(save-excursion
|
||
(save-restriction
|
||
(let* ((proc (get-buffer-process (current-buffer)))
|
||
(mark (and proc (process-mark proc))))
|
||
|
||
(if (and mark (>= (point) mark))
|
||
(narrow-to-region mark (point)))
|
||
|
||
(and ess-noweb-mode
|
||
(ess-noweb-narrow-to-chunk))
|
||
|
||
(unless (ess-inside-string-p)
|
||
(setq ess--funname.start
|
||
(condition-case nil ;; check if it is inside a functon
|
||
(progn
|
||
;; for the sake of big buffers, look only 1000 chars back
|
||
(narrow-to-region (max (point-min) (- (point) 1000)) (point))
|
||
(up-list -1)
|
||
(while (not (looking-at "("))
|
||
(up-list -1))
|
||
(let ((funname (symbol-name (symbol-at-point))))
|
||
(when (and funname
|
||
(not (member funname ess-S-non-functions)))
|
||
(cons funname (- (point) (length funname))))
|
||
))
|
||
(error nil))
|
||
))))))
|
||
|
||
(defun ess-function-arguments (funname &optional proc)
|
||
"Get FUNARGS from cache or ask the process for it.
|
||
|
||
Return FUNARGS - a list with the first element being a
|
||
cons (package_name . time_stamp_of_request), second element is a
|
||
string giving arguments of the function as they appear in
|
||
documentation, third element is a list of arguments of all
|
||
methods.
|
||
|
||
If package_name is nil, and time_stamp is less recent than the
|
||
time of the last user interaction to the process, then update the
|
||
entry.
|
||
|
||
Package_name is also nil when funname was not found, or funname
|
||
is a special name that contains :,$ or @.
|
||
|
||
If PROC is given, it should be an ESS process which should be
|
||
queried for arguments.
|
||
"
|
||
|
||
(when (and funname ;; usually returned by ess--funname.start (might be nil)
|
||
(or proc (ess-process-live-p)))
|
||
(let* ((proc (or proc (get-process ess-local-process-name)))
|
||
(args (gethash funname (process-get proc 'funargs-cache)))
|
||
(pack (caar args))
|
||
(ts (cdar args)))
|
||
(when (and args
|
||
(and (time-less-p ts (process-get proc 'last-eval))
|
||
(or (null pack)
|
||
(equal pack ""))))
|
||
;; reset cache
|
||
(setq args nil))
|
||
(or args
|
||
(cadr (assoc funname (process-get proc 'funargs-pre-cache)))
|
||
(and
|
||
(not (process-get proc 'busy))
|
||
(with-current-buffer (ess-command (format ess-funargs-command
|
||
(ess-quote-special-chars funname))
|
||
nil nil nil nil proc)
|
||
(goto-char (point-min))
|
||
(when (re-search-forward "(list" nil t)
|
||
(goto-char (match-beginning 0))
|
||
(setq args (ignore-errors (eval (read (current-buffer)))))
|
||
(if args
|
||
(setcar args (cons (car args) (current-time)))))
|
||
;; push even if nil
|
||
(puthash (substring-no-properties funname) args (process-get proc 'funargs-cache))))))))
|
||
|
||
(defun ess-symbol-at-point ()
|
||
"Like `symbol-at-point' but consider fully qualified names.
|
||
Fully qualified names include accessor symbols (like aaa$bbb and
|
||
aaa@bbb in R)."
|
||
(with-syntax-table (or ess-mode-completion-syntax-table
|
||
ess-mode-syntax-table
|
||
(syntax-table))
|
||
(symbol-at-point)))
|
||
|
||
(defun ess-symbol-start ()
|
||
"Get initial position for objects completion.
|
||
Symbols are fully qualified names that include accessor
|
||
symbols (like aaa$bbb and aaa@bbb in R)."
|
||
(let ((beg (car (with-syntax-table (or ess-mode-completion-syntax-table
|
||
ess-mode-syntax-table
|
||
(syntax-table))
|
||
(bounds-of-thing-at-point 'symbol)))))
|
||
(when (and beg (not (save-excursion (goto-char beg)
|
||
(looking-at "/\\|.[0-9]"))))
|
||
beg)))
|
||
|
||
(defun ess-arg-start ()
|
||
"Get initial position for args completion"
|
||
(when (not (ess-inside-string-p))
|
||
(when (ess--funname.start)
|
||
(if (looking-back "[(,]+[ \t\n]*" nil)
|
||
(point)
|
||
(ess-symbol-start)))))
|
||
|
||
(defun ess-inside-string-or-comment-p (&optional pos)
|
||
"Return non-nil if POSition [defaults to (point)] is inside string or comment
|
||
(according to syntax)."
|
||
;;FIXME (defun ess-calculate-indent ..) can do that ...
|
||
(interactive)
|
||
(setq pos (or pos (point)))
|
||
(let ((ppss (syntax-ppss pos)))
|
||
(or (car (setq ppss (nthcdr 3 ppss)))
|
||
(car (setq ppss (cdr ppss)))
|
||
(nth 3 ppss))))
|
||
|
||
(defun ess-inside-string-p (&optional pos)
|
||
"Return non-nil if point is inside string (according to syntax)."
|
||
(interactive)
|
||
;; when narrowing the buffer in iESS the ppss cahce is screwed:( But it is
|
||
;; very fast, so don't bother for now.
|
||
(let ((pps (syntax-ppss pos)))
|
||
(nth 3 pps))
|
||
;; (nth 3 (parse-partial-sexp (point-min) pos))
|
||
)
|
||
|
||
(defun ess-inside-comment-p (&optional pos)
|
||
"Return non-nil if point is inside string (according to syntax)."
|
||
(interactive)
|
||
(setq pos (or pos (point)))
|
||
(save-excursion
|
||
(or (when font-lock-mode ;; this is a shortcut (works well usually)
|
||
(let ((face (get-char-property pos 'face)))
|
||
(eq 'font-lock-comment-face face)))
|
||
(nth 4 (parse-partial-sexp (progn (goto-char pos) (point-at-bol)) pos)))))
|
||
|
||
(defun ess-inside-brackets-p (&optional pos curly?)
|
||
"Return t if position POS is inside brackets.
|
||
POS defaults to point if no value is given. If curly? is non nil
|
||
also return t if inside curly brackets."
|
||
(save-excursion
|
||
(let ((ppss (syntax-ppss pos))
|
||
(r nil))
|
||
(while (and (> (nth 0 ppss) 0)
|
||
(not r))
|
||
(goto-char (nth 1 ppss))
|
||
(when (or (char-equal ?\[ (char-after))
|
||
(and curly?
|
||
(char-equal ?\{ (char-after))))
|
||
(setq r t))
|
||
(setq ppss (syntax-ppss)))
|
||
r)))
|
||
|
||
|
||
;;*;; String manipulation
|
||
|
||
(defun ess-quote-special-chars (string)
|
||
(replace-regexp-in-string
|
||
"\"" "\\\\\\&"
|
||
(replace-regexp-in-string ;; replace backslashes
|
||
"\\\\" "\\\\" string nil t)))
|
||
|
||
;; simple alternative to ess-read-object-name-default of ./ess-inf.el :
|
||
;; is "wrongly" returning "p1" for word "p1.part2" :
|
||
(defun ess-extract-word-name ()
|
||
"Get the word you're on (cheap algorithm). Use `ess-read-object-name-default'
|
||
for a better but slower version."
|
||
(save-excursion
|
||
(re-search-forward "\\<\\w+\\>" nil t)
|
||
(buffer-substring (match-beginning 0) (match-end 0))))
|
||
|
||
(defun ess-rep-regexp (regexp to-string &optional fixedcase literal verbose)
|
||
"Instead of (replace-regexp..) -- do NOT replace in strings or comments.
|
||
If FIXEDCASE is non-nil, do *not* alter case of replacement text.
|
||
If LITERAL is non-nil, do *not* treat `\\' as special.
|
||
If VERBOSE is non-nil, (message ..) about replacements."
|
||
(let ((case-fold-search (and case-fold-search
|
||
(not fixedcase))); t <==> ignore case in search
|
||
(ppt (point)); previous point
|
||
(p))
|
||
(while (and (setq p (re-search-forward regexp nil t))
|
||
(< ppt p))
|
||
(setq ppt p)
|
||
(cond ((not (ess-inside-string-or-comment-p (1- p)))
|
||
(if verbose
|
||
(let ((beg (match-beginning 0)))
|
||
(message "buffer in (match-beg.,p)=(%d,%d) is '%s'"
|
||
beg p (buffer-substring beg p))))
|
||
(replace-match to-string fixedcase literal)
|
||
;;or (if verbose (setq pl (append pl (list p))))
|
||
)))
|
||
;;or (if (and verbose pl)
|
||
;;or (message "s/%s/%s/ at %s" regexp to-string pl))
|
||
) )
|
||
|
||
(defun ess-replace-regexp-dump-to-src
|
||
(regexp to-string &optional dont-query verbose ensure-mode)
|
||
"Depending on dont-query, call `ess-rep-regexp' or `query-replace-regexp'
|
||
from the beginning of the buffer."
|
||
(save-excursion
|
||
(if (and ensure-mode
|
||
(not (equal major-mode 'ess-mode)))
|
||
(ess-mode))
|
||
(goto-char (point-min))
|
||
(if dont-query
|
||
(ess-rep-regexp regexp to-string nil nil verbose)
|
||
(query-replace-regexp regexp to-string nil))))
|
||
|
||
(defun ess-space-around (word &optional from verbose)
|
||
"Replace-regexp .. ensuring space around all occurences of WORD,
|
||
starting from FROM {defaults to (point)}."
|
||
(interactive "d\nP"); Defaults: point and prefix (C-u)
|
||
(save-excursion
|
||
(goto-char from)
|
||
(ess-rep-regexp (concat "\\([^ \t\n]\\)\\(\\<" word "\\>\\)")
|
||
"\\1 \\2" nil nil verbose)
|
||
(goto-char from)
|
||
(ess-rep-regexp (concat "\\(\\<" word "\\>\\)\\([^ \t\n]\\)")
|
||
"\\1 \\2" nil nil verbose)
|
||
)
|
||
)
|
||
|
||
(defun ess-time-string (&optional clock)
|
||
"Returns a string for use as a timestamp. + hr:min if CLOCK is non-nil,
|
||
like \"13 Mar 1992\". Redefine to taste."
|
||
(format-time-string (concat "%e %b %Y" (if clock ", %H:%M"))))
|
||
|
||
(defun ess-replace-in-string (str regexp newtext &optional literal)
|
||
"Replace all matches in STR for REGEXP with NEWTEXT string.
|
||
Optional LITERAL non-nil means do a literal replacement.
|
||
Otherwise treat \\ in NEWTEXT string as special:
|
||
\\& means substitute original matched text,
|
||
\\N means substitute match for \(...\) number N,
|
||
\\\\ means insert one \\."
|
||
(if (not (stringp str))
|
||
(error "(replace-in-string): First argument must be a string: %s" str))
|
||
(if (stringp newtext)
|
||
nil
|
||
(error "(replace-in-string): 3rd arg must be a string: %s"
|
||
newtext))
|
||
(let ((rtn-str "")
|
||
(start 0)
|
||
(special)
|
||
match prev-start)
|
||
(while (setq match (string-match regexp str start))
|
||
(setq prev-start start
|
||
start (match-end 0)
|
||
rtn-str
|
||
(concat
|
||
rtn-str
|
||
(substring str prev-start match)
|
||
(cond (literal newtext)
|
||
(t (mapconcat
|
||
(function
|
||
(lambda (c)
|
||
(if special
|
||
(progn
|
||
(setq special nil)
|
||
(cond ((eq c ?\\) "\\")
|
||
((eq c ?&)
|
||
(substring str
|
||
(match-beginning 0)
|
||
(match-end 0)))
|
||
((and (>= c ?0) (<= c ?9))
|
||
(if (> c (+ ?0 (length
|
||
(match-data))))
|
||
;; Invalid match num
|
||
(error "(replace-in-string) Invalid match num: %c" c)
|
||
(setq c (- c ?0))
|
||
(substring str
|
||
(match-beginning c)
|
||
(match-end c))))
|
||
(t (char-to-string c))))
|
||
(if (eq c ?\\) (progn (setq special t) nil)
|
||
(char-to-string c)))))
|
||
newtext ""))))))
|
||
(concat rtn-str (substring str start))))
|
||
|
||
;;- From: friedman@gnu.ai.mit.edu (Noah Friedman)
|
||
;;- Date: 12 Feb 1995 21:30:56 -0500
|
||
;;- Newsgroups: gnu.emacs.sources
|
||
;;- Subject: nuke-trailing-whitespace
|
||
;;-
|
||
;;- This is too trivial to make into a big todo with comments and copyright
|
||
;;- notices whose length exceed the size of the actual code, so consider it
|
||
;;- public domain. Its purpose is along similar lines to that of
|
||
;;- `require-final-newline', which is built in. I hope the names make it
|
||
;;- obvious.
|
||
|
||
;; (add-hook 'write-file-hooks 'nuke-trailing-whitespace)
|
||
;;or at least
|
||
;; (add-hook 'ess-mode-hook
|
||
;; (lambda ()
|
||
;; (add-hook 'local-write-file-hooks 'nuke-trailing-whitespace)))
|
||
|
||
(defvar ess-nuke-trailing-whitespace-p nil;disabled by default 'ask
|
||
"*[Dis]activates (ess-nuke-trailing-whitespace).
|
||
Disabled if `nil'; if `t', it works unconditionally, otherwise,
|
||
the user is queried.
|
||
Note that setting the default to `t' may not be a good idea when you edit
|
||
binary files!")
|
||
|
||
;;; MM: Newer Emacsen now have delete-trailing-whitespace
|
||
;;; -- but no customization like nuke-trailing-whitespace-p ..
|
||
(defun ess-nuke-trailing-whitespace ()
|
||
"Nuke all trailing whitespace in the buffer.
|
||
Whitespace in this case is just spaces or tabs.
|
||
This is a useful function to put on write-file-hooks.
|
||
|
||
If the variable `ess-nuke-trailing-whitespace-p' is `nil', this function is
|
||
disabled. If `t', unreservedly strip trailing whitespace.
|
||
If not `nil' and not `t', query for each instance."
|
||
(interactive)
|
||
(let ((bname (buffer-name)))
|
||
(cond ((or
|
||
(string= major-mode "rmail-mode")
|
||
(string= bname "RMAIL")
|
||
nil)); do nothing..
|
||
|
||
(t
|
||
(and (not buffer-read-only)
|
||
ess-nuke-trailing-whitespace-p
|
||
(save-match-data
|
||
(save-excursion
|
||
(save-restriction
|
||
(widen)
|
||
(goto-char (point-min))
|
||
(cond ((eq ess-nuke-trailing-whitespace-p t)
|
||
(while (re-search-forward "[ \t]+$" (point-max) t)
|
||
(delete-region (match-beginning 0)
|
||
(match-end 0))))
|
||
(t
|
||
(query-replace-regexp "[ \t]+$" "")))))))))
|
||
;; always return nil, in case this is on write-file-hooks.
|
||
nil))
|
||
|
||
|
||
;;*;; Debugging tools
|
||
|
||
(defun ess-write-to-dribble-buffer (text)
|
||
"Write TEXT to dribble ('*ESS*') buffer."
|
||
(unless (buffer-live-p ess-dribble-buffer)
|
||
;; ESS dribble buffer must be re-created.
|
||
(setq ess-dribble-buffer (get-buffer-create "*ESS*")))
|
||
(let (deactivate-mark)
|
||
(with-current-buffer ess-dribble-buffer
|
||
(goto-char (point-max))
|
||
(insert-before-markers text))))
|
||
|
||
;; Shortcut to render "dribbling" statements less cluttering:
|
||
(defun ess-if-verbose-write (text)
|
||
"Write TEXT to dribble buffer ('*ESS*') only *if* `ess-verbose'."
|
||
(if ess-verbose (ess-write-to-dribble-buffer text)))
|
||
|
||
|
||
(defun ess-kill-last-line ()
|
||
(save-excursion
|
||
(goto-char (point-max))
|
||
(forward-line -1)
|
||
(delete-region (point-at-eol) (point-max))))
|
||
|
||
(defvar ess-adjust-chunk-faces t
|
||
"Whether to adjust background color in code chunks.")
|
||
|
||
(defvar-local ess-buffer-has-chunks nil
|
||
"Internal usage: indicates whether a buffer has chunks.
|
||
This is used to make face adjustment a no-op when a buffer does
|
||
not contain chunks.")
|
||
|
||
(defvar ess-adjust-face-intensity 2
|
||
"Default intensity for adjusting faces.")
|
||
|
||
(defun ess-adjust-face-background (start end &optional intensity)
|
||
"Adjust face background between BEG and END.
|
||
On dark background, lighten. Oposite on light."
|
||
(let* ((intensity (or intensity ess-adjust-face-intensity))
|
||
(color (color-lighten-name
|
||
(face-background 'default)
|
||
(if (eq (frame-parameter nil 'background-mode) 'light)
|
||
(- intensity)
|
||
intensity)))
|
||
(face (list (cons 'background-color color))))
|
||
(with-silent-modifications
|
||
(ess-adjust-face-properties start end 'face face))))
|
||
|
||
;; Taken from font-lock.el.
|
||
(defun ess-adjust-face-properties (start end prop value)
|
||
"Tweaked `font-lock-prepend-text-property'.
|
||
Adds the `ess-face-adjusted' property so we only adjust face once."
|
||
(let ((val (if (listp value) value (list value))) next prev)
|
||
(while (/= start end)
|
||
(setq next (next-single-property-change start prop nil end)
|
||
prev (get-text-property start prop))
|
||
;; Canonicalize old forms of face property.
|
||
(and (memq prop '(face font-lock-face))
|
||
(listp prev)
|
||
(or (keywordp (car prev))
|
||
(memq (car prev) '(foreground-color background-color)))
|
||
(setq prev (list prev)))
|
||
(add-text-properties start next
|
||
(list prop (append val (if (listp prev) prev (list prev)))
|
||
'ess-face-adjusted t))
|
||
(setq start next))))
|
||
|
||
(defun ess-find-overlay (pos prop)
|
||
(cl-some (lambda (overlay)
|
||
(when (overlay-get overlay prop)
|
||
overlay))
|
||
(overlays-at pos)))
|
||
|
||
(provide 'ess-utils)
|
||
|
||
; Local variables section
|
||
|
||
;;; This file is automatically placed in Outline minor mode.
|
||
;;; The file is structured as follows:
|
||
;;; Chapters: ^L ;
|
||
;;; Sections: ;;*;;
|
||
;;; Subsections: ;;;*;;;
|
||
;;; Components: defuns, defvars, defconsts
|
||
;;; Random code beginning with a ;;;;* comment
|
||
|
||
;;; Local variables:
|
||
;;; mode: emacs-lisp
|
||
;;; mode: outline-minor
|
||
;;; outline-regexp: "\^L\\|\\`;\\|;;\\*\\|;;;\\*\\|(def[cvu]\\|(setq\\|;;;;\\*"
|
||
;;; End:
|
||
|
||
;;; ess-utils.el ends here
|