ess-developer.el

;;; ess-developer.el --- Developer mode for R.

;; Copyright (C) 2011-2012 V. Spinu, A.J. Rossini, Richard M. Heiberger, Martin
;;      Maechler, Kurt Hornik, Rodney Sparapani, and Stephen Eglen.

;; Author: Vitalie Spinu
;; Created: 12-11-2011
;; Maintainer: ESS-core <[email protected]>

;; Keywords: languages, tools

;; This file is part of ESS.

;; 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/

;;; Commentary:

;; see apropriate documentation section of ESS user manual

;;; Code:

;; (require 'ess-site) ;; need to assigne the keys in the map

(defgroup ess-developer nil
  "ESS: developer."
  :group 'ess
  :prefix "ess-developer-")

(defface ess-developer-indicator-face
  '((((class grayscale)) (:background "DimGray"))
    (((class color) (background light))
     (:foreground "red4"  :bold t ))
    (((class color) (background dark))
     (:foreground "deep sky blue"  :bold t )))
  "Face to highlight mode line process name when developer mode is on."
  :group 'ess-developer)

(defcustom ess-developer-packages nil
  "List of names of R packages you develop.
Use `ess-developer-add-package' to modify interactively this
list. "
  :group 'ess-developer
  :type 'list)

(defcustom ess-developer-load-package-command "library(devtools)\nload_all('%s')\n"
  "Command issued by `ess-developer-load-package'.
 %s is subsituted with the user supplied directory."
  :group 'ess-developer
  :type 'string)

(defvar ess-developer-root-file "DESCRIPTION"
  "If this file is present in the directory, it is considered a
  project root.")

;; (defcustom ess-developer-force-attach nil
;;   "If non-nill all the packages listed in `ess-developer-packages' should be attached
;; when ess-developer mode is turned on."
;;   :group 'ess-developer
;;   :type 'boolean)

(defcustom ess-developer-enter-hook nil
  "Normal hook run on entering `ess-developer' mode."
  :group 'ess-developer
  :type 'hook)

(defcustom ess-developer-exit-hook nil
  "Normal hook run on exiting `ess-developer' mode."
  :group 'ess-developer
  :type 'hook)

(defcustom ess-developer-activate-in-package t
  "If non-nil, ess-developer is automatically toggled in files
within package directory."
  :group 'ess-developer
  :type 'boolean)

(defcustom ess-developer-load-on-add-commands '(("library" . "library(%n)")
                                                ("load_all" . "library(devtools)\nload_all('%d')"))
  "Alist of available load commands what are proposed for loading
on `ess-developer-add-package'.

  %n is replaced with package name,
  %d is replaced with package directory.

See also `ess-developer-load-package' for related functionality."
  :group 'ess-developer
  :type 'alist)

(defvar ess-developer--load-hist nil)

(defun ess-developer-add-package (&optional attached-only)
  "Add a package to `ess-developer-packages' list.
With prefix argument only choose from among attached packages."
  (interactive "P")
  (ess-force-buffer-current)
  (let* ((packs (ess-get-words-from-vector
                 (format "print(unique(c(.packages(), %s)), max=1e6)\n"
                         (if attached-only "NULL" ".packages(TRUE)") nil t)))
         (cur-pack (ess-developer--get-package-name))
         (sel (ess-completing-read "Add package" packs nil nil nil nil
                                   (unless (member cur-pack ess-developer-packages)
                                     cur-pack)))
         (check-attached (format ".ess_package_attached('%s')\n" sel)))
    (unless (ess-boolean-command check-attached)
      (let* ((fn (if (> (length ess-developer-load-on-add-commands) 1)
                     (ess-completing-read "Package not loaded. Use"
                                          (mapcar 'car ess-developer-load-on-add-commands) nil t
                                          nil 'ess-developer--load-hist
                                          (car ess-developer--load-hist))
                   (caar ess-developer-load-on-add-commands)))
             (cmd (cdr (assoc fn ess-developer-load-on-add-commands))))
        (setq cmd (replace-regexp-in-string "%n" sel cmd))
        (when (string-match-p "%d" cmd)
          (let ((dir (read-directory-name
                      "Package: " (ess-developer--get-package-path sel) nil t nil)))
            (setq cmd (replace-regexp-in-string "%d" dir cmd))))
        (ess-eval-linewise (concat cmd "\n")))
      (ess-wait-for-process)
      (when (not (ess-boolean-command check-attached))
        (error "Package '%s' could not be added" sel)))
    (setq ess-developer-packages
          (ess-uniq-list (append ess-developer-packages (list sel))))
    ;; turn developer in all files from selected package
    (ess-developer-activate-in-package sel 'all)
    (message "You are developing: %s" ess-developer-packages)))

(defun ess-developer-remove-package ()
  "Remove packages from `ess-developer-packages' list; defaults to *ALL*."
  (interactive)
  (unless ess-developer-packages
    (error "Nothing to remove, 'ess-developer-packages' is empty"))
  (let ((sel (ess-completing-read "Remove package(s)"
                                  (append ess-developer-packages (list "*ALL*"))
                                  nil t nil nil "*ALL*")))
    (if (equal "*ALL*" sel)
        (progn
          (setq ess-developer-packages nil)
          (ess-developer-deactivate-in-package nil 'all)
          (message "Removed *ALL* packages from the `ess-developer-packages' list."))
      (setq ess-developer-packages (delete sel ess-developer-packages))
      (ess-developer-deactivate-in-package sel 'all)
      (message "Removed package '%s' from the `ess-developer-packages' list"
               (propertize sel 'face 'font-lock-function-name-face)))))

(defun ess-developer-send-region-fallback (proc beg end visibly &optional message tracebug func)
  (if tracebug
      (ess-tracebug-send-region proc beg end visibly message t)
    (ess-send-region proc beg end visibly message)))

(defun ess-developer-source-current-file (&optional filename)
  "Ask for namespace to source the current file into.
If *current* is selected just invoke source('file_name'),
otherwise call devSource."
  (interactive)
  (ess-force-buffer-current "R process to use: ")
  (unless ess-developer
    (error "Ess-developer mode is not active"))
  (if (not (or filename
               buffer-file-name))
      (error "Buffer '%s' doesn't visit a file" (buffer-name (current-buffer)))
    (let* ((filename (or filename buffer-file-name))
           (file (file-name-nondirectory filename))
           (env (ess-completing-read (format "devSource '%s' into" file)
                                     (append ess-developer-packages (list "*current*" )) nil t))
           (comm  (if (equal env "*current*")
                      (format "source(file=\"%s\", local=F)\n cat(\"Sourced file '%s' into\", capture.output(environment()), '\n')" filename file)
                    (format ".essDev_source(source='%s',package='%s')" filename env))))
      (when (buffer-modified-p) (save-buffer))
      (message "devSourcing '%s' ..." file)
      (ess-developer--command comm 'ess-developer--propertize-output))))

(defun ess-developer-send-function (proc beg end name &optional visibly message tracebug)
  (save-excursion
    (if (null ess-developer-packages)
        (error "`ess-developer-packages' is empty (add packages with C-c C-t C-a).")
      (if (null name)
          (error "Oops, could not find function name (probably a regexp bug)")
        (let ((nms (ess-get-words-from-vector "loadedNamespaces()\n"))
              (dev-packs ess-developer-packages)
              assigned-p ns)
          ;; such a kludge
          (if (string-match-p ess-set-function-start (concat name "("))
              (ess-developer-send-region proc beg end visibly message tracebug)
            (if tracebug (ess-tracebug-set-last-input proc))
            (while (and (setq ns (pop dev-packs))
                        (not assigned-p))
              (when (and (member ns nms) ;;todo: try to load the package if not loaded
                         (ess-boolean-command
                          (format "as.character(exists('%s', envir=asNamespace('%s'), mode='function', inherits=FALSE))\n"
                                  name ns)))
                (ess-developer-devSource beg end ns message)
                (setq assigned-p t)))
            (unless assigned-p
              (ess-developer-send-region-fallback proc beg end visibly message tracebug))))))))

(defvar ess-developer--hist nil)

(defun ess-developer-send-region (proc beg end &optional visibly message tracebug)
  "Ask for for the package and devSource region into it."
  (let* ((all-packs (append ess-developer-packages (list "*current*" )))
         (default (car (member (car ess-developer--hist) all-packs)))
         (package
          (ess-completing-read "devEval into" all-packs
                               nil t nil 'ess-developer--hist default)))
    (message  (if message (format "dev%s ..." message)))
    (if (equal package "*current*")
        (ess-developer-send-region-fallback proc beg end visibly message tracebug)
      ;; else, (ignore VISIBLY here)
      (ess-developer-devSource beg end package message))))

(defun ess-developer-devSource (beg end package &optional message)
  (let* ((ess-eval-command
          (format ".essDev.eval(\"%s\", package=\"%s\", file=\"%s\")" "%s" package "%f"))
         (ess-eval-visibly-command ess-eval-command)
         (ess-eval-visibly-noecho-command ess-eval-command))
    (if message (message message))
    (ess-developer--command (ess--make-source-refd-command beg end)
                            'ess-developer--propertize-output)))

(defun ess-developer--command (comm &optional propertize-func)
  "Evaluate the command and popup a message with the output if succed.
On error  insert the error at the end of the inferior-ess buffer.

PROPERTIZE-FUNC is a function called with the output buffer being
current. usually used to manipulate the output, for example to
propertize output text.
"
  (setq comm (format "eval({cat(\"\\n\")\n%s\ncat(\"!@OK@!\")})\n" comm))
  (let ((buff (get-buffer-create " *ess-command-output*"))
        out)
    (ess-command comm buff nil nil 0.1)
    (with-current-buffer buff
      (goto-char (point-min))
      (delete-region (point) (min (point-max) ;; delete + + +
                                  (1+ (point-at-eol))))
      (goto-char (point-max))
      (if (re-search-backward "!@OK@!" nil t)
          (progn
            (when (fboundp propertize-func)
              (save-excursion (funcall propertize-func)))
            (message "%s" (buffer-substring (point-min) (max (point-min)
                                                             (1- (point))))))
        (message "%s" (buffer-substring-no-properties (point-min) (point-max)))))))

(defun ess-developer--propertize-output ()
  (goto-char (point-min))
  (while (re-search-forward "\\(FUN\\|CLS\\METH\\)\\[" nil t)
    (put-text-property (match-beginning 1) (match-end 1)
                       'face 'font-lock-function-name-face))
  (goto-char (point-min))
  (while (re-search-forward "\\([^ \t]+\\):" nil t)
    (put-text-property (match-beginning 1) (match-end 1)
                       'face 'font-lock-keyword-face)))

(defvar ess-developer--pack-name nil)
(make-variable-buffer-local 'ess-developer--pack-name)

(defun ess-developer--get-package-path (&optional pack-name)
  "Get the root of R package that contains current directory.
Root is determined by locating `ess-developer-root-file'.

If PACK-NAME is given, iterate over default-directories of all
open R files till package with name pack-name is found. If not
found, return nil."
  (if pack-name
      (let ((bl (buffer-list))
            path bf)
        (while (and (setq bf (pop bl))
                    (not path))
          (when (buffer-local-value 'ess-dialect bf)
            (with-current-buffer bf
              (setq path (ess-developer--get-package-path))
              (unless ess-developer--pack-name
                (setq ess-developer--pack-name ;; cache locally 
                      (ess-developer--get-package-name path)))
              (unless (equal ess-developer--pack-name pack-name)
                (setq path nil)))))
        path)
    (let ((path default-directory)
          opath package)
      (while (and path
                  (not package)
                  (not (equal path opath)))
        (if (file-exists-p (expand-file-name ess-developer-root-file path))
            (setq package path)
          (setq opath path
                path (file-name-directory (directory-file-name path)))))
      package)))


(defun ess-developer--get-package-name (&optional path)
  "Find package name in path. Parses DESCRIPTION file in PATH (R
specific so far). PATH defaults to `default-directory'"
  (when (setq path (or path (ess-developer--get-package-path)))
    (let ((file (expand-file-name ess-developer-root-file path))
          (case-fold-search t))
      (when (file-exists-p file)
        (with-temp-buffer
          (insert-file-contents file)
          (goto-char (point-min))
          (re-search-forward "package: \\(.*\\)")
          (match-string 1))))))

(defun ess-developer-activate-in-package (&optional package all)
  "Activate developer if current file is part of a package which
is registered in `ess-developer-packages'.

If PACKAGE is given, activate only if current file is part of the
PACKAGE, `ess-developer-packages' is ignored in this case.

If ALL is non-nil, perform activation in all R buffers.

This function does nothing if `ess-developer-activate-in-package'
is nil. "
  (when ess-developer-activate-in-package
    (if all
        (dolist (bf (buffer-list))
          (with-current-buffer bf
            (ess-developer-activate-in-package package)))
      (let ((pack (ess-developer--get-package-name)))
        (when (and buffer-file-name
                   pack
                   (not ess-developer)
                   (if package
                       (equal pack package)
                     (member pack ess-developer-packages)))
          (ess-developer t))))))

(defun ess-developer-deactivate-in-package (&optional package all)
  "Deactivate developer if current file is part of the R package.

If PACKAGE is given, deactivate only if current package is
PACKAGE.

If ALL is non-nil, deactivate in all open R buffers."
  (if all
      (dolist (bf (buffer-list))
        (with-current-buffer bf
          (ess-developer-deactivate-in-package package)))
    (let ((pack (ess-developer--get-package-name)))
      (when (and ess-developer
                 (or (null package)
                     (equal pack package)))
        (ess-developer -1)))))

(defun ess-developer-load-package ()
  "Interface to load_all function from devtools package."
  (interactive)
  (ess-force-buffer-current)
  (let ((package (ess-developer--get-package-path)))
    (unless (and package ess-developer)
      ;; ask only when not obvious
      (setq package
            (read-directory-name "Package: " package nil t nil)))
    (unless (file-exists-p (expand-file-name ess-developer-root-file package))
      (error "Not a valid package. No '%s' found in `%s'."
             ess-developer-root-file package))
    (message "Loading %s" (abbreviate-file-name package))
    (ess-eval-linewise
     (format ess-developer-load-package-command package))))

(defvar ess-developer nil
  "Non nil in buffers where developer mode is active")
(make-variable-buffer-local 'ess-developer)

;; Since the ESSR package, this one is not needed:
;; (defun ess-developer--inject-source-maybe ()
;;   ;; puting this into ESSR.R makes loading very slow
;;   ;; when ESSR is a package, this should go away
;;   (let ((devR-file (concat (file-name-directory ess-etc-directory)
;;                            "ess-developer.R")))
;;     (unless (ess-boolean-command
;;              "exists('.essDev_source', envir = .ESSR_Env)\n")
;;       (unless (file-exists-p devR-file)
;;         (error "Cannot locate 'ess-developer.R' file"))
;;       (message "Injecting ess-developer code ...")
;;       (ess--inject-code-from-file devR-file)
;;       (unless (ess-boolean-command "exists('.essDev_source', envir = .ESSR_Env)\n")
;;         (error "Could not source ess-developer.R. Please investigate the output of *ess-command-output* buffer for errors")))))

(defun ess-developer (&optional val)
  "Toggle on/off ess-developer functionality.
If optional VAL is non-negative, turn on the developer mode. If
VAL is negative turn it off."
  (interactive)
  (when (eq val t) (setq val 1))
  (let ((ess-dev  (if (numberp val)
                      (if (< val 0) nil t)
                    (not ess-developer))))
    (if ess-dev
        (progn
          (run-hooks 'ess-developer-enter-hook)
          (if ess-developer-packages
              (message "You are developing: %s" ess-developer-packages)
            (message "Developer is on (add packages with C-c C-t a)")))
      (run-hooks 'ess-developer-exit-hook)
      (message "%s developer is off" (if (get-buffer-process (current-buffer))
                                              "Global"
                                            "Local")))

    (setq ess-developer ess-dev))
    (force-window-update))

(defalias 'ess-toggle-developer 'ess-developer)



;;; MODELINE

(defvar ess-developer--local-indicator 
  '(""
    (:eval
     ;; process has priority
     (if (and (ess-process-live-p)
              (ess-get-process-variable 'ess-developer))
         (propertize " D" 'face 'ess-developer-indicator-face)
       (if ess-developer
           (propertize " d" 'face 'ess-developer-indicator-face)
         "")))))
(put 'ess-developer--local-indicator 'risky-local-variable t)

(defun ess-developer-setup-modeline ()
  (add-to-list 'ess--local-mode-line-process-indicator
               'ess-developer--local-indicator 'append))



;;; HOOKS

(add-hook 'R-mode-hook 'ess-developer-activate-in-package)
(add-hook 'R-mode-hook 'ess-developer-setup-modeline)
(add-hook 'inferior-ess-mode-hook 'ess-developer-setup-modeline)

(provide 'ess-developer)
;;; ess-developer.el ends here