Klimi's new dotfiles with stow.
您最多选择25个主题 主题必须以字母或数字开头,可以包含连字符 (-),并且长度不得超过35个字符

2798 行
118 KiB

  1. ;; ess-tracebug.el --- Tracing and debugging facilities for ESS. -*- lexical-binding: t; -*-
  2. ;;
  3. ;; Copyright (C) 2011--2017 A.J. Rossini, Richard M. Heiberger, Martin Maechler,
  4. ;; Kurt Hornik, Rodney Sparapani, Stephen Eglen and Vitalie Spinu.
  5. ;;
  6. ;; Filename: ess-tracebug.el
  7. ;; Author: Vitalie Spinu
  8. ;; Maintainer: Vitalie Spinu
  9. ;; Copyright (C) 2010-2012, Vitalie Spinu, all rights reserved.
  10. ;; Created: Oct 14 14:15:22 2010
  11. ;; URL: https://code.google.com/p/ess-tracebug/
  12. ;; Keywords: tools, languages
  13. ;;
  14. ;; This file is *NOT* part of GNU Emacs.
  15. ;;
  16. ;; This program is free software; you can redistribute it and/or
  17. ;; modify it under the terms of the GNU General Public License as
  18. ;; published by the Free Software Foundation; either version 3, any later version.
  19. ;;
  20. ;; This program is distributed in the hope that it will be useful, but WITHOUT
  21. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  22. ;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
  23. ;; details.
  24. ;;
  25. ;; A copy of the GNU General Public License is available at
  26. ;; https://www.r-project.org/Licenses/
  27. ;;; Commentary:
  28. ;; Ess-tracebug is a package for interactive debugging of R code from
  29. ;; ESS and provides such features as:
  30. ;; - visual debugging
  31. ;; - browser, recover and conditional breakpoints
  32. ;; - watch window and loggers
  33. ;; - on the fly debug/undebug of R functions and methods
  34. ;; - highlighting of error source references and easy error navigation
  35. ;; - interactive traceback.
  36. ;;
  37. ;; For a complete description please see the documentation in the ESS
  38. ;; manual.
  39. ;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41. ;;
  42. ;;; Code:
  43. (eval-when-compile
  44. (when (< emacs-major-version 26)
  45. (require 'cl))
  46. (require 'cl-lib)
  47. (require 'tramp)
  48. (require 'subr-x))
  49. (require 'comint)
  50. (require 'compile)
  51. (require 'ring)
  52. (require 'ess-utils)
  53. (defvar text-scale-mode-amount)
  54. (autoload 'text-scale-mode "face-remap" "[autoload]" nil)
  55. ;; Silence the byte compiler. This is OK here because this file is
  56. ;; only loaded from ess-inf and has no autoloads.
  57. ;; TODO: This is a LOT. Can we move some of this around?
  58. (defvar ess--dbg-del-empty-p)
  59. (defvar inferior-ess-mode-map)
  60. (defvar ess-mode-map)
  61. (defvar ess--inhibit-presend-hooks)
  62. (declare-function ess--accumulation-buffer "ess-inf")
  63. (declare-function ess--if-verbose-write-process-state "ess-inf")
  64. (declare-function ess--run-presend-hooks "ess-inf")
  65. (declare-function ess-boolean-command "ess-inf")
  66. (declare-function ess-build-eval-command "ess-inf")
  67. (declare-function ess-build-load-command "ess-inf")
  68. (declare-function ess-command "ess-inf")
  69. (declare-function ess-dirs "ess-inf")
  70. (declare-function ess-force-buffer-current "ess-inf")
  71. (declare-function ess-get-process "ess-inf")
  72. (declare-function ess-get-process-variable "ess-inf")
  73. (declare-function ess-get-words-from-vector "ess-inf")
  74. (declare-function ess-process-get "ess-inf")
  75. (declare-function ess-process-live-p "ess-inf")
  76. (declare-function ess-process-put "ess-inf")
  77. (declare-function ess-send-string "ess-inf")
  78. (declare-function ess-switch-process "ess-inf" ())
  79. (declare-function ess-switch-to-ESS "ess-inf")
  80. (declare-function ess-wait-for-process "ess-inf")
  81. (declare-function ess-switch-to-end-of-ESS "ess-inf" ())
  82. (declare-function ess-eval-region--normalise-region "ess-inf" )
  83. (declare-function inferior-ess-run-callback "ess-inf")
  84. (declare-function inferior-ess--set-status "ess-inf")
  85. (declare-function ess-helpobjs-at-point--read-obj "ess-help")
  86. (declare-function ess-r-get-evaluation-env "ess-r-mode")
  87. (declare-function ess-r-package--all-source-dirs "ess-r-package")
  88. (declare-function ess-r-package-name "ess-r-package")
  89. (declare-function ess-r-package-source-dirs "ess-r-package")
  90. ;; Do not require tramp at runtime. It is expensive to load. Instead,
  91. ;; guard calls with (require 'tramp) and silence the byte compiler
  92. ;; here.
  93. (declare-function tramp-dissect-file-name "tramp")
  94. (declare-function tramp-get-remote-tmpdir "tramp")
  95. ;; The following declares can be removed once we drop Emacs 25
  96. (declare-function tramp-file-name-method "tramp")
  97. (declare-function tramp-file-name-user "tramp")
  98. (declare-function tramp-file-name-host "tramp")
  99. (declare-function tramp-file-name-localname "tramp")
  100. (declare-function tramp-file-name-hop "tramp")
  101. (defgroup ess-tracebug nil
  102. "Error navigation and debugging for ESS.
  103. Currently only R is supported."
  104. :link '(emacs-library-link :tag "Source Lisp File" "ess-tracebug.el")
  105. :group 'ess)
  106. (defvar ess-tracebug-indicator " TB"
  107. "String to be displayed in mode-line alongside the process name.
  108. Indicates that ess-tracebug-mode is turned on.")
  109. (defvar ess-watch-mode-map
  110. (let ((map (make-sparse-keymap)))
  111. (define-key map "k" #'ess-watch-kill)
  112. ;; (define-key ess-watch-mode-map "u" #'ess-watch-undelete)
  113. ;; editing requires a little more work.
  114. (define-key map "a" #'ess-watch-add)
  115. (define-key map "i" #'ess-watch-insert)
  116. (define-key map "e" #'ess-watch-edit-expression)
  117. (define-key map "r" #'ess-watch-rename)
  118. (define-key map "q" #'ess-watch-quit)
  119. (define-key map "u" #'ess-watch-move-up)
  120. (define-key map "U" #'ess-watch-move-down)
  121. (define-key map "d" #'ess-watch-move-down)
  122. (define-key map "n" #'ess-watch-next-block)
  123. (define-key map "p" #'ess-watch-previous-block)
  124. ;; R mode keybindings.
  125. (define-key map "\C-c\C-s" #'ess-switch-process)
  126. (define-key map "\C-c\C-y" #'ess-switch-to-ESS)
  127. (define-key map "\C-c\C-z" #'ess-switch-to-end-of-ESS)
  128. map)
  129. "Keymap for `ess-watch-mode'.")
  130. (defcustom ess-tracebug-prefix nil
  131. "Key to be used as prefix for all `ess-tracebug' commands.
  132. Set this to a key combination you don't use often, like:
  133. (setq ess-tracebug-prefix \"\\M-t\")
  134. The postfix keys are defined in `ess-tracebug-map':
  135. \\{ess-tracebug-map}"
  136. :type '(choice (const nil) (string))
  137. :group 'ess-tracebug)
  138. (defcustom ess-tracebug-search-path nil
  139. "List of directories to search for source files.
  140. Elements should be directory names, not file names of directories."
  141. :type '(choice (const :tag "Unset" nil)
  142. (repeat :tag "Directory list" (string :tag "Directory")))
  143. :group 'ess-debug)
  144. (defvar ess-watch-buffer "*R watch*"
  145. "Name of the watch buffer.")
  146. (defcustom ess-watch-height-threshold nil
  147. "Minimum height for splitting *R* window sensibly to make space for watch window.
  148. See `split-height-threshold' for a detailed description.
  149. If nil, the value of `split-height-threshold' is used."
  150. :group 'ess-debug
  151. :type '(choice (const nil) (integer)))
  152. (defcustom ess-watch-width-threshold nil
  153. "Minimum width for splitting *R* window sensibly to make space for watch window.
  154. See `split-width-threshold' for a detailed description.
  155. If nil, the value of `split-width-threshold' is used."
  156. :group 'ess-debug
  157. :type '(choice (const nil) (integer)))
  158. (defcustom ess-watch-scale-amount -1
  159. "The number of steps to scale the watch font down (up).
  160. Each step scales the height of the default face in the watch
  161. window by the variable `text-scale-mode-step' (a negative number
  162. of steps decreases the height by the same amount)"
  163. :group 'ess-debug
  164. :type 'integer)
  165. (defvar-local ess-watch-current-block-overlay nil
  166. "The overlay for currently selected block in the R watch buffer .")
  167. (defcustom ess-inject-source 'function-and-buffer
  168. "Control the source injection into evaluated code.
  169. If t, always inject source reference.
  170. If function, inject only for functions,
  171. If function-and-buffer, inject for functions and whole buffer (the default),
  172. If nil, never inject.
  173. When tracebug is active (the default), ESS instructs the
  174. subprocess to keep the source code references.
  175. If this variable is t, you won't be able to execute blocks which
  176. don't form a valid R expression. That is, if your expression
  177. spreads multiple paragraphs, and you call
  178. \\[ess-eval-region-or-function-or-paragraph-and-step] on first
  179. paragraph, R will report an error."
  180. :group 'ess-tracebug
  181. :type '(choice (const nil) (const function) (const function-and-buffer) (const t)))
  182. (defcustom ess-tracebug-enter-hook nil
  183. "List of functions to call on entry to `ess-tracebug' mode.
  184. Use `add-hook' to insert append your functions to this list."
  185. :group 'ess-tracebug
  186. :type 'hook)
  187. (defcustom ess-tracebug-exit-hook nil
  188. "List of functions to call on exit of `ess-tracebug' mode.
  189. Use `add-hook' to insert append your functions to this list."
  190. :group 'ess-tracebug
  191. :type 'hook)
  192. (defvaralias 'ess-tracebug-map 'ess-dev-map)
  193. (defvar ess--tracebug-eval-index 0
  194. "This is used by to track source references in evaluation with source.
  195. For example, each time `ess-eval-function' is called the evaluated
  196. region is marked. When debugger enters the code it displays
  197. this reference number. Ess-debug finds this number in the
  198. referenced buffer.")
  199. ;; these vars are org variables that store the src block locations
  200. (defvar org-edit-src-beg-marker nil)
  201. (defvar org-babel-current-src-block-location nil
  202. "Marker pointing to the src block currently being executed.
  203. This may also point to a call line or an inline code block. If
  204. multiple blocks are being executed (e.g., in chained execution
  205. through use of the :var header argument) this marker points to
  206. the outer-most code block.")
  207. ;; hash to store source references of the form: tmpname -> (filename . src_start)
  208. (defvar ess--srcrefs (make-hash-table :test 'equal :size 100))
  209. (defvar ess-tracebug-original-buffer-marker nil
  210. "Marker pointing to the beginning of original source code.
  211. If non-nil, tracebug will insert the source references based on
  212. this location instead of the current buffer. This is useful for
  213. applications, like org-babel, that call ess evaluation functions
  214. from temporary buffers.")
  215. (defun ess-tracebug-p ()
  216. "Return non-nil if tracebug is running."
  217. (ess-process-get 'tracebug))
  218. (defun ess-make-source-refd-command (beg end visibly process)
  219. "Saves a region to a temporary file in order to add source references.
  220. BEG and END delimit the region. Returns a string containing an
  221. inferior process command for loading the temporary file. This
  222. command conforms to VISIBLY."
  223. (let* ((filename buffer-file-name)
  224. (proc-dir (ess-get-process-variable 'default-directory))
  225. (remote (when (file-remote-p proc-dir)
  226. (require 'tramp)
  227. ;; should this be done in process buffer?
  228. (tramp-dissect-file-name proc-dir)))
  229. (orig-marker (or ess-tracebug-original-buffer-marker
  230. org-edit-src-beg-marker
  231. org-babel-current-src-block-location))
  232. orig-beg)
  233. (setq ess--tracebug-eval-index (1+ ess--tracebug-eval-index))
  234. (goto-char beg)
  235. (skip-chars-forward " \t\n")
  236. (setq beg (point))
  237. (goto-char end)
  238. (skip-chars-backward " \t\n")
  239. (setq end (point)
  240. orig-beg beg)
  241. ;; Delete all old temp files
  242. (when (and (not (ess-process-get 'busy))
  243. (< 1 (float-time
  244. (time-subtract (current-time)
  245. (ess-process-get 'last-eval)))))
  246. (dolist (f (ess-process-get 'temp-source-files))
  247. (and (file-exists-p f)
  248. (delete-file f)))
  249. (ess-process-put 'temp-source-files nil))
  250. (when (markerp orig-marker)
  251. (setq filename (buffer-file-name (marker-buffer orig-marker)))
  252. (setq orig-beg (+ beg (marker-position orig-marker))))
  253. (let ((tmpfile
  254. (expand-file-name (make-temp-name
  255. (concat (file-name-nondirectory
  256. (or filename "unknown")) "!"))
  257. (if remote
  258. (tramp-get-remote-tmpdir remote)
  259. temporary-file-directory))))
  260. (ess-process-put 'temp-source-files
  261. (cons tmpfile (ess-process-get 'temp-source-files)))
  262. (when remote
  263. ;; Get local name (should this be done in process buffer?)
  264. (setq tmpfile (with-parsed-tramp-file-name tmpfile nil localname)))
  265. (if (not filename)
  266. (puthash tmpfile (list nil ess--tracebug-eval-index nil) ess--srcrefs)
  267. (puthash tmpfile (list filename ess--tracebug-eval-index orig-beg) ess--srcrefs)
  268. (puthash (file-name-nondirectory tmpfile) ; R sometimes strips dirs
  269. (list filename ess--tracebug-eval-index orig-beg) ess--srcrefs)
  270. (with-silent-modifications
  271. (put-text-property beg end 'tb-index ess--tracebug-eval-index)))
  272. (let ((string (ess-process-buffer-substring process beg end)))
  273. (or
  274. ;; Sending string to subprocess is considerably faster than tramp file
  275. ;; transfer. So, give priority to `ess-eval-command' if available
  276. (ess-build-eval-command string visibly t tmpfile)
  277. ;; When no `ess-eval-command' available, use `ess-load-command'
  278. (progn
  279. (write-region beg end tmpfile nil 'silent)
  280. (ess-build-load-command tmpfile visibly t)))))))
  281. (defun ess-process-buffer-substring (process start end)
  282. (ess--run-presend-hooks process (buffer-substring-no-properties start end)))
  283. (defun ess-tracebug-send-region (process start end &optional visibly message type)
  284. "Send region to process adding source references as specified
  285. by `ess-inject-source' variable."
  286. (ess-eval-region--normalise-region start end)
  287. (let* ((inject-p (cond ((eq type 'function)
  288. ess-inject-source)
  289. ((eq type 'buffer)
  290. (or (eq ess-inject-source t)
  291. (eq ess-inject-source 'function-and-buffer)))
  292. (t (or (eq ess-inject-source t)
  293. ;; We need to always inject with namespaced
  294. ;; evaluation (fixme: not right place for
  295. ;; this).
  296. (ess-r-get-evaluation-env)))))
  297. (ess--dbg-del-empty-p (unless inject-p ess--dbg-del-empty-p))
  298. (string (if inject-p
  299. (ess-make-source-refd-command start end visibly process)
  300. (ess-process-buffer-substring process start end)))
  301. (message (if (fboundp ess-build-eval-message-function)
  302. (funcall ess-build-eval-message-function message)
  303. message)))
  304. ;; Don't run the presend hooks twice.
  305. (let ((ess--inhibit-presend-hooks t))
  306. (process-put process :eval-visibly visibly)
  307. ;; Visible evaluation is not nice when sourcing temporary files. You get
  308. ;; .ess.eval(*code*) instead of *code*.
  309. (setq visibly (unless inject-p visibly))
  310. (ess-send-string process string visibly message))))
  311. (defun ess-tracebug-send-function (proc start end &optional visibly message)
  312. "Like `ess-tracebug-send-region' but with tweaks for functions."
  313. (ess-tracebug-send-region proc start end visibly message 'function))
  314. (defvar ess-tracebug-help nil
  315. "ess-dev-map prefix: \\[ess-dev-map]
  316. * Breakpoints (`ess-dev-map'):
  317. b . Set BP (repeat to cycle BP type) . `ess-bp-set'
  318. B . Set conditional BP . `ess-bp-set-conditional'
  319. k . Kill BP . `ess-bp-kill'
  320. K . Kill all BPs . `ess-bp-kill-all'
  321. o . Toggle BP state . `ess-bp-toggle-state'
  322. l . Set logger BP . `ess-bp-set-logger'
  323. n . Goto next BP . `ess-bp-next'
  324. p . Goto previous BP . `ess-bp-previous'
  325. (C- prefixed equivalents are also defined)
  326. * Debugging (`ess-dev-map'):
  327. ` . Show traceback . `ess-show-traceback' (also on C-c `)
  328. ~ . Show callstack . `ess-show-call-stack' (also on C-c ~)
  329. e . Toggle error action (repeat to cycle). `ess-debug-toggle-error-action'
  330. d . Flag for debugging . `ess-debug-flag-for-debugging'
  331. u . Unflag for debugging . `ess-debug-unflag-for-debugging'
  332. w . Watch window . `ess-watch'
  333. (C- prefixed equivalents are also defined)
  334. * Interactive Debugging (`ess-debug-minor-mode-map'):
  335. M-C . Continue . `ess-debug-command-continue'
  336. M-C-C . Continue multi . `ess-debug-command-continue-multi'
  337. M-N . Next step . `ess-debug-command-next'
  338. M-C-N . Next step multi . `ess-debug-command-next-multi'
  339. M-U . Up frame . `ess-debug-command-up'
  340. M-Q . Quit debugging . `ess-debug-command-quit'
  341. * Navigation to errors (general Emacs functionality):
  342. C-x `, M-g n . `next-error'
  343. M-g p . `previous-error'")
  344. ;; * Input Ring:
  345. ;; i . Goto input event marker forwards . `ess-debug-goto-input-event-marker'
  346. ;; I . Goto input event marker backwards . `ess-debug-goto-input-event-marker'
  347. (defun ess-tracebug-show-help ()
  348. "Show help for `ess-tracebug'."
  349. (interactive)
  350. (describe-variable 'ess-tracebug-help))
  351. (defun ess-tracebug--propertize (dummy bitmap face &optional string )
  352. "If `window-system' propertize DUMMY with fringe BITMAP and FACE.
  353. Otherwise, propertize line-prefix and margin with STRING and FACE"
  354. (unless string
  355. (setq string dummy))
  356. (if window-system
  357. (propertize dummy 'display (list 'left-fringe bitmap face))
  358. (propertize dummy
  359. 'display (list '(margin left-margin)
  360. (propertize string
  361. 'font-lock-face face
  362. 'face face)))))
  363. (defun ess-tracebug (&optional arg)
  364. "Toggle `ess-tracebug' mode.
  365. With ARG, turn `ess-tracebug' mode on if and only if ARG is
  366. positive.
  367. This mode adds to ESS the interactive debugging, breakpoint and
  368. error navigation functionality. Strictly speaking `ess-tracebug'
  369. is not a minor mode. It integrates globally into ESS and iESS.
  370. Note: Currently, `ess-tracebug' does not detect some of R's debug
  371. related messages in non-English locales. To set your R messages
  372. to English add the following line to your .Rprofile init file:
  373. Sys.setlocale(\"LC_MESSAGES\", \"C\")
  374. See `ess-tracebug-help' for the overview of ess-tracebug functionality."
  375. ;; Note: The functionality in ess-tracebug is divided on conceptual
  376. ;; grounds in tracing and debugging and could be
  377. ;; activated/deactivate separately with `ess--tb-start' and
  378. ;; `ess-debug-start' respectively.
  379. (interactive "P")
  380. (ess-force-buffer-current "R process to activate tracebug in: ")
  381. (with-current-buffer (process-buffer (get-process ess-local-process-name))
  382. (when (equal ess-dialect "R")
  383. (setq arg
  384. (if arg
  385. (prefix-numeric-value arg)
  386. (if (ess-process-get 'tracebug) -1 1)))
  387. (if (> arg 0)
  388. (unless (ess-process-get 'tracebug) ;; only if already not active
  389. (ess--tb-start)
  390. (ess-debug-start)
  391. ;; (dolist (bf (buffer-list))
  392. ;; (with-current-buffer bf
  393. ;; (when (and (eq major-mode 'ess-mode)
  394. ;; (equal ess-dialect "R"))
  395. ;; (ess-bp-recreate-all))))
  396. ;; watch functionality
  397. (if ess-tracebug-prefix
  398. (let ((comm (key-binding ess-tracebug-prefix)))
  399. ;; (message "ess-tracebug-prefix will be removed in future versions. Electric debug keys are now on [C-c] and [C-c C-t] maps.")
  400. ;; (sit-for 1)
  401. (when (commandp comm)
  402. (define-key ess-tracebug-map ess-tracebug-prefix comm))
  403. (define-key ess-mode-map ess-tracebug-prefix ess-tracebug-map)
  404. (define-key inferior-ess-mode-map ess-tracebug-prefix ess-tracebug-map)
  405. (define-key ess-watch-mode-map ess-tracebug-prefix ess-tracebug-map)))
  406. (run-hooks 'ess-tracebug-enter-hook)
  407. (ess-process-put 'tracebug t)
  408. (message "ess-tracebug mode enabled"))
  409. (when (ess-process-get 'tracebug) ;;only when active
  410. (ess-process-put 'tracebug nil)
  411. ;; unset the map
  412. (when ess-tracebug-prefix
  413. (define-key ess-mode-map ess-tracebug-prefix nil)
  414. (define-key inferior-ess-mode-map ess-tracebug-prefix nil))
  415. (ess--tb-stop)
  416. (ess-debug-stop)
  417. (run-hooks 'ess-tracebug-exit-hook)
  418. (message "ess-tracebug mode disabled"))))))
  419. (defalias 'ess-toggle-tracebug 'ess-tracebug)
  420. ;;;_* TRACEBACK
  421. ;; (defface ess--tb-last-input-face
  422. ;; '((((class grayscale)
  423. ;; (background light)) (:background "DimGray"))
  424. ;; (((class grayscale)
  425. ;; (background dark)) (:background "LightGray"))
  426. ;; (((class color) (background light) (min-colors 88))
  427. ;; (:overline "medium blue" ))
  428. ;; (((class color) (background dark) (min-colors 88))
  429. ;; (:overline "deep sky blue" ))
  430. ;; (((background light)) (:weight bold))
  431. ;; (((background dark)) (:weight bold))
  432. ;; )
  433. ;; "Face to highlight currently debugged line."
  434. ;; :group 'ess-tracebug )
  435. (defface ess-tracebug-last-input-fringe-face
  436. '((((background light) (min-colors 88)) (:foreground "medium blue" :overline "medium blue"))
  437. (((background dark) (min-colors 88)) (:foreground "deep sky blue" :overline "deep sky blue"))
  438. (((background light) (min-colors 8)) (:foreground "blue"))
  439. (((background dark) (min-colors 8)) (:foreground "syan")))
  440. "Face for fringe bitmap for last-input position."
  441. :group 'ess-tracebug)
  442. (if (fboundp 'define-fringe-bitmap)
  443. (define-fringe-bitmap 'last-input-arrow
  444. [#b00011111
  445. #b00010000
  446. #b00010000
  447. #b00010000
  448. #b00010000
  449. #b00010000
  450. #b00010000
  451. #b00010000
  452. #b00010000
  453. #b00010000
  454. #b11010111
  455. #b01111100
  456. #b00111000
  457. #b00010000] nil nil 'top))
  458. (defvar ess--tb-last-input (make-marker)
  459. "Marker pointing to the last user input position in iESS buffer.
  460. This is the place where `ess--tb-last-input-overlay' is moved.
  461. Local in iESS buffers with `ess-tracebug' mode enabled.")
  462. (defvar ess--tb-last-input-overlay nil
  463. "Overlay to highlight the position of last input in iESS buffer.
  464. Local in iESS buffers.")
  465. (defvar-local ess--busy-count 0
  466. "Used to compute the busy indicator.")
  467. ;; (unless (boundp 'ess--busy-slash)
  468. ;; (defvar ess--busy-slash '(32 ?\u2014 92 47))
  469. ;; (setq ess--busy-slash (mapcar (lambda (el) (format " %c " el))
  470. ;; ess--busy-slash))
  471. ;; )
  472. (defvar ess--busy-slash '(" " " - " " \\ " " / "))
  473. (defvar ess--busy-B '(" " " B " " "))
  474. (defvar ess--busy-stars '(" " " " " * " " ** " " *** " " **** "))
  475. (defvar ess--busy-vbars '(" " " " " | " " || " " ||| " " |||| "))
  476. (defcustom ess-busy-strings ess--busy-slash
  477. "List of strings to replace in turn for busy indication.
  478. The first element of the list is used as an indicator of the
  479. process being ready (i.e. not busy). Implemented lists that you
  480. can use `ess--busy-slash', `ess--busy-B',`ess--busy-stars',
  481. `ess--busy-vbars'"
  482. :group 'ess
  483. :type '(repeat string))
  484. (defvar ess--busy-timer nil
  485. "Timer used for busy process indication.")
  486. (defcustom inferior-ess-replace-long+ t
  487. "Determines if ESS replaces long + sequences in output.
  488. If 'strip, remove all such instances. Otherwise, if non-nil, '+
  489. + + + ' containing more than 4 + is replaced by
  490. `ess-long+replacement'."
  491. :group 'ess-tracebug
  492. :type '(choice (const nil :tag "No replacement")
  493. (const 'strip :tag "Replace all")
  494. (const t :tag "Replace 4 or more +")))
  495. (defvar ess-long+replacement ". + "
  496. "Replacement used for long + prompt.
  497. Please don't customize this or other prompt related variables.
  498. ESS internal code assumes default R prompts.")
  499. (defmacro ess-copy-key (from-map to-map fun)
  500. `(define-key ,to-map
  501. (car (where-is-internal ,fun ,from-map))
  502. ,fun))
  503. ;;;_ + traceback functions
  504. (defun ess--tb-make-last-input-overlay (beg end)
  505. "Create an overlay to indicate the last input position."
  506. (let ((ove (make-overlay beg end)))
  507. (overlay-put ove 'before-string
  508. (ess-tracebug--propertize "!" 'last-input-arrow 'ess-tracebug-last-input-fringe-face))
  509. ;; (overlay-put ove 'face 'ess--tb-last-input-face)
  510. (overlay-put ove 'evaporate t)
  511. ove))
  512. (defun ess--tb-start ()
  513. "Start traceback session."
  514. (with-current-buffer (process-buffer (get-process ess-local-process-name))
  515. (unless ess-error-regexp-alist
  516. (error "Can not activate the traceback for %s dialect" ess-dialect))
  517. (setq-local compilation-error-regexp-alist ess-error-regexp-alist)
  518. (let (compilation-mode-font-lock-keywords)
  519. (compilation-setup t))
  520. (setq next-error-function 'ess-tracebug-next-error-function)
  521. ;; new locals
  522. (make-local-variable 'ess--tb-last-input)
  523. (make-local-variable 'ess--tb-last-input-overlay)
  524. (make-local-variable 'compilation-search-path)
  525. (setq compilation-search-path ess-tracebug-search-path) ;; TODO: make this dialect specific
  526. (ess-tracebug--set-left-margin)
  527. (save-excursion
  528. (goto-char comint-last-input-start)
  529. (setq ess--tb-last-input (point))
  530. (setq ess--tb-last-input-overlay
  531. (ess--tb-make-last-input-overlay
  532. (point-at-bol) (point-at-eol))))
  533. ;; busy timer
  534. (setq mode-line-buffer-identification
  535. (list (car (propertized-buffer-identification "%3b"))
  536. `(:eval (nth ess--busy-count ess-busy-strings)))) ;; 'face 'mode-line-buffer-id))))
  537. (make-local-variable 'ess--busy-timer)
  538. (setq ess--busy-timer
  539. (run-with-timer 2 .5 (ess--make-busy-timer-function (get-buffer-process (current-buffer)))))
  540. (add-hook 'kill-buffer-hook (lambda () (when ess--busy-timer (cancel-timer ess--busy-timer))))
  541. (add-hook 'comint-input-filter-functions 'ess-tracebug-set-last-input nil 'local)
  542. ;; redefine
  543. ;; TODO: all this part should go (partially gone now)
  544. (unless (fboundp 'orig-ess-parse-errors)
  545. (defalias 'orig-ess-parse-errors (symbol-function 'ess-parse-errors))
  546. (defalias 'ess-parse-errors (symbol-function 'next-error)))))
  547. (defun ess--tb-stop ()
  548. "Stop ess traceback session in the current ess process."
  549. (with-current-buffer (process-buffer (get-process ess-current-process-name))
  550. ;; restore original definitions
  551. (when (equal ess-dialect "R")
  552. (when (fboundp 'orig-ess-parse-errors)
  553. (defalias 'ess-parse-errors (symbol-function 'orig-ess-parse-errors))
  554. (fmakunbound 'orig-ess-parse-errors)))
  555. (if (local-variable-p 'ess--tb-last-input-overlay)
  556. (delete-overlay ess--tb-last-input-overlay))
  557. (kill-local-variable 'ess--tb-last-input-overlay)
  558. (kill-local-variable 'ess--tb-last-input)
  559. (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords))
  560. (font-lock-ensure)
  561. (kill-local-variable 'compilation-error-regexp-alist)
  562. (kill-local-variable 'compilation-search-path)
  563. (cancel-timer ess--busy-timer)
  564. (remove-hook 'comint-input-filter-functions 'ess-tracebug-set-last-input 'local)
  565. (setq mode-line-buffer-identification (propertized-buffer-identification "%12b"))))
  566. (defvar ess--dbg-forward-ring (make-ring 10)
  567. "Ring of markers to the positions of user inputs when the
  568. debugger or traceback events are initiated. It is used in
  569. `ess--dbg-goto-input-point'.")
  570. (defvar ess--dbg-backward-ring (make-ring 10)
  571. "Ring of markers to the positions from which `ess--dbg-goto-input-point' is called.
  572. See the also `ess--dbg-goto-debug-point'")
  573. ;; (setq ess-R--tb-regexp-alist '(R R2 R3 R-recover))
  574. ;;(pop compilation-error-regexp-alist-alist)
  575. (defun ess-show-traceback ()
  576. "Display R traceback and last error message.
  577. Pop up a compilation/grep/occur like buffer. Usual global key
  578. bindings are available (\\[next-error] and \\[previous-error])
  579. for `next-error' and `previous-error' respectively.
  580. You can bind 'no-select' versions of this commands:
  581. \(define-key compilation-minor-mode-map [(?n)] #'next-error-no-select)
  582. \(define-key compilation-minor-mode-map [(?p)] #'previous-error-no-select)"
  583. (interactive)
  584. (cl-assert ess-traceback-command nil
  585. "Not implemented for dialect %s" ess-dialect)
  586. (ring-insert ess--dbg-forward-ring (point-marker))
  587. (ess-force-buffer-current "R process to use: ")
  588. (let ((trbuf (get-buffer-create "*ess-traceback*"))
  589. (lproc-name ess-local-process-name)
  590. (alist ess-mode-editing-alist)
  591. (cmd ess-traceback-command)
  592. (inhibit-read-only t))
  593. (setq next-error-last-buffer trbuf)
  594. (with-current-buffer trbuf
  595. (setq ess-local-process-name lproc-name)
  596. (ess-command cmd trbuf)
  597. (goto-char (point-min))
  598. ;; fixme: this is R specific check
  599. (cl-assert (not (re-search-forward "No traceback available" nil t)) nil
  600. "No traceback available")
  601. (ess-dirs)
  602. (when (boundp 'ess-r-error-regexp-alist)
  603. (setq-local compilation-error-regexp-alist ess-r-error-regexp-alist))
  604. (setq-local compilation-search-path ess-tracebug-search-path)
  605. (ess-setq-vars-local alist)
  606. (font-lock-refresh-defaults)
  607. (compilation-minor-mode 1)
  608. (setq next-error-function #'ess-tracebug-next-error-function)
  609. (setq buffer-read-only t)
  610. (pop-to-buffer trbuf))))
  611. (defvar ess-call-stack-command nil)
  612. (defun ess-show-call-stack ()
  613. "Display current call stack.
  614. Also see `ess-show-traceback'"
  615. (interactive)
  616. (let ((ess-traceback-command ess-call-stack-command))
  617. (ess-show-traceback)))
  618. (defalias 'ess-show-R-traceback 'ess-show-traceback)
  619. (defun ess--tb-next-error-goto-process-marker ()
  620. ;; assumes current buffer is the process buffer with compilation enabled
  621. ;; used in ess-tracebug-next-error-function
  622. ; (with-current-buffer (process-buffer (get-process ess-local-process-name)) ; already in comint buffer .. no need
  623. (comint-goto-process-mark)
  624. (set-window-point (get-buffer-window) (point)) ;moves the cursor
  625. ;; FIXME: Should jump to current-debug-position, but messes the things if in recover
  626. ;; (when (ess-debug-is-active)
  627. ;; (ess-debug-goto-current-debug-position)
  628. ;; )
  629. )
  630. (defun ess-tracebug-next-error-function (n &optional reset)
  631. "Advance to the next error message and visits the file.
  632. This is the value of `next-error-function' in iESS buffers."
  633. ;; Modified version of `compilation-next-error-function'.
  634. (interactive "p")
  635. (if reset (goto-char (point-max)))
  636. (let* (;; (columns compilation-error-screen-columns) ; buffer's local value
  637. ;; (proc (or (get-buffer-process (current-buffer))
  638. ;; (error "Current buffer has no process")))
  639. (pbuff-p (get-buffer-process (current-buffer)))
  640. (n (or n 1))
  641. (beg-pos ; from where the search for next error starts
  642. (if (and pbuff-p
  643. (>= n 0)
  644. (comint-after-pmark-p))
  645. ess--tb-last-input
  646. (point)))
  647. (at-error t)
  648. (msg
  649. (condition-case nil
  650. (compilation-next-error n nil beg-pos)
  651. (error
  652. (when pbuff-p
  653. (ess--tb-next-error-goto-process-marker))
  654. (if (< n 0)
  655. (message "Before first reference")
  656. (message "Beyond last reference"));(error-message-string err))
  657. (setq at-error nil))))
  658. (msg (if (or (not pbuff-p)
  659. (eq n 0)
  660. (> (point) ess--tb-last-input))
  661. msg
  662. (ess--tb-next-error-goto-process-marker)
  663. (message "Beyond last-input marker")
  664. (setq at-error nil)))
  665. (marker (point-marker))
  666. loc)
  667. (when at-error
  668. (setq compilation-current-error (point-marker)
  669. overlay-arrow-position (if (bolp)
  670. compilation-current-error
  671. (copy-marker (line-beginning-position)))
  672. loc (if (fboundp 'compilation--message->loc)
  673. (compilation--message->loc msg)
  674. (car msg)))
  675. (let* ((file (caar (nth 2 loc)))
  676. (col (car loc))
  677. (line (cadr loc))
  678. (mkrs (ess--dbg-create-ref-marker file line col)))
  679. (if mkrs
  680. ;; is this really needed? Shall we go directly to the location?
  681. (compilation-goto-locus marker (car mkrs) (cadr mkrs))
  682. (message "Reference to '%s' not found" file))))))
  683. (defun inferior-ess-move-last-input-overlay ()
  684. "Move the overlay to the point."
  685. (let ((pbol (point-at-bol)))
  686. (move-overlay ess--tb-last-input-overlay
  687. pbol (max (- (point) 2) (+ pbol 2)))))
  688. ;;;_* DEBUGGER
  689. (defgroup ess-debug nil
  690. "Debugging for ESS"
  691. :link '(emacs-library-link :tag "Source Lisp File" "ess-tracebug.el")
  692. :group 'ess-tracebug
  693. :prefix "ess-debug-")
  694. (defcustom ess-debug-error-action-alist
  695. '(( "" "NONE" "NULL" )
  696. ( " r" "RECOVER" "utils::recover")
  697. ( " t" "TRACEBACK" "base::traceback"))
  698. "Alist of 'on-error' actions.
  699. Toggled with `ess-debug-toggle-error-action'. Each element must
  700. have the form (DISP SYMB ACTION) where DISP is the string to be
  701. displayed in the mode line when the action is in place. SYMB is
  702. the symbolic name of an action. ACTION is the string giving the
  703. actual expression to be assigned to 'error' user option. See R's
  704. help ?options for more details."
  705. :type '(alist :key-type string
  706. :value-type (group string string))
  707. :group 'ess-debug)
  708. (defvar ess--dbg-output-buf-prefix " *ess.dbg"
  709. "The prefix of the buffer name the R debug output is directed to." )
  710. (defvar-local ess--dbg-current-ref (make-marker)
  711. "Current debug reference in *ess.dbg* buffers (a marker).")
  712. (defvar-local ess--dbg-last-ref-marker (make-marker)
  713. "Last debug reference in *ess.dbg* buffer (a marker).")
  714. (defvar-local ess--dbg-buf-p nil
  715. "This is t in ess.dbg buffers.")
  716. ;; (defcustom ess--dbg-auto-single-key-p t
  717. ;; "If t entering the debug state triggers single-key mode.
  718. ;; Set it to nil if you want to trigger single-key mode manually
  719. ;; with the `ess-tracebug-prefix' key.
  720. ;; ")
  721. (defvar ess--dbg-current-debug-position (make-marker)
  722. "Marker to the current debugged line.
  723. It always point to the beginning of the currently debugged line
  724. and is used by overlay-arrow.
  725. In no-windowed Emacs an `overlay-arrow' is displayed at this position.")
  726. (unless window-system
  727. (add-to-list 'overlay-arrow-variable-list 'ess--dbg-current-debug-position))
  728. (defface ess-debug-current-debug-line-face
  729. '((default (:inherit highlight)))
  730. "Face used to highlight currently debugged line."
  731. :group 'ess-debug)
  732. (defvar ess--dbg-current-debug-overlay
  733. (let ((overlay (make-overlay (point) (point))))
  734. (overlay-put overlay 'face 'ess-debug-current-debug-line-face)
  735. (overlay-put overlay 'evaporate t)
  736. overlay)
  737. ;; should be global variable!!
  738. "The overlay for currently debugged line.")
  739. (defcustom ess-debug-blink-interval .2
  740. "Time in seconds to blink the background of the debug line.
  741. Currently two events are defined 'ref-not-found' and 'same-ref'.
  742. Blinking colors for these events can be customized by
  743. corresponding faces."
  744. :group 'ess-debug
  745. :type 'float)
  746. (defface ess-debug-blink-ref-not-found-face
  747. '((((class grayscale) (background light)) (:background "DimGray"))
  748. (((class grayscale) (background dark)) (:background "LightGray"))
  749. (((class color) (background light) (min-colors 88)) (:background "IndianRed4"))
  750. (((class color) (background dark) (min-colors 88)) (:background "dark red"))
  751. (((background light) (min-colors 8)) (:foreground "red"))
  752. (((background dark) (min-colors 8)) (:foreground "red")))
  753. "Face used to blink currently debugged line's background
  754. when the reference file is not found. See also `ess-debug-ask-for-file'"
  755. :group 'ess-debug )
  756. (defface ess-debug-blink-same-ref-face
  757. '((((class grayscale) (background light)) (:background "DimGray"))
  758. (((class grayscale) (background dark)) (:background "LightGray"))
  759. (((class color) (background light) (min-colors 88)) (:background "steel blue"))
  760. (((class color) (background dark) (min-colors 88)) (:background "midnight blue"))
  761. (((background light) (min-colors 8)) (:foreground "blue"))
  762. (((background dark) (min-colors 8)) (:foreground "cyan")))
  763. "Face used to highlight currently debugged line when new debug
  764. reference is the same as the preceding one. It is highlighted for
  765. `ess-debug-blink-interval' seconds."
  766. :group 'ess-debug )
  767. (defcustom ess-debug-ask-for-file nil
  768. "If non nil, ask for file if the current debug reference is not found.
  769. If nil, the currently debugged line is highlighted for
  770. `ess-debug-blink-interval' seconds."
  771. :group 'ess-debug
  772. :type 'boolean)
  773. (defcustom ess-debug-skip-first-call t
  774. "If non-nil, skip first debugger call.
  775. In R first call doesn't contain source references and is skipped
  776. by default."
  777. :group 'ess-debug
  778. :type 'boolean)
  779. (defvar ess-electric-selection-map
  780. (let (ess-electric-selection-map)
  781. (define-prefix-command 'ess-electric-selection-map)
  782. ;; command-c and command-Q are not always working reliably
  783. (define-key ess-electric-selection-map "\M-N" #'ess-debug-command-continue)
  784. (define-key ess-electric-selection-map "\M-C" #'ess-debug-command-continue)
  785. (define-key ess-electric-selection-map "\M-Q" #'ess-debug-command-quit)
  786. (define-key ess-electric-selection-map "0" #'ess-debug-command-digit)
  787. (define-key ess-electric-selection-map "1" #'ess-debug-command-digit)
  788. (define-key ess-electric-selection-map "2" #'ess-debug-command-digit)
  789. (define-key ess-electric-selection-map "3" #'ess-debug-command-digit)
  790. (define-key ess-electric-selection-map "4" #'ess-debug-command-digit)
  791. (define-key ess-electric-selection-map "5" #'ess-debug-command-digit)
  792. (define-key ess-electric-selection-map "6" #'ess-debug-command-digit)
  793. (define-key ess-electric-selection-map "7" #'ess-debug-command-digit)
  794. (define-key ess-electric-selection-map "8" #'ess-debug-command-digit)
  795. (define-key ess-electric-selection-map "9" #'ess-debug-command-digit)
  796. (define-key ess-electric-selection-map "?" #'ess-tracebug-show-help)
  797. ess-electric-selection-map)
  798. "Keymap used to define commands for single key input mode.
  799. This commands are triggered by `ess-electric-selection' .
  800. \\{ess-electric-selection-map}")
  801. ;;;_ + debug functions
  802. (defun ess-debug-set-error-action (spec)
  803. "Set the on-error action.
  804. The SPEC should be one of the components of
  805. `ess-debug-error-action-alist'."
  806. (let ((proc (get-process ess-local-process-name)))
  807. (if spec
  808. (with-current-buffer (process-buffer proc)
  809. (process-put proc 'on-error-action (car spec))
  810. (ess-command (format "options(error= %s )\n" (nth 2 spec))))
  811. (error "Unknown action"))))
  812. (defun ess-debug-toggle-error-action ()
  813. "Toggle the 'on-error' action.
  814. The action list is in `ess-debug-error-action-alist'."
  815. (interactive)
  816. (ess-force-buffer-current)
  817. (let* ((ev last-command-event)
  818. (com-char (event-basic-type ev))
  819. (cur-action (or (ess-process-get 'on-error-action) ""))
  820. actions act)
  821. (setq actions
  822. (cdr (member (assoc cur-action ess-debug-error-action-alist)
  823. ess-debug-error-action-alist)))
  824. (unless actions
  825. (setq actions ess-debug-error-action-alist))
  826. (setq act (pop actions))
  827. (ess-debug-set-error-action act)
  828. (message "On-error action set to: %s"
  829. (propertize (cadr act) 'face 'font-lock-function-name-face))
  830. (while (eq (event-basic-type (setq ev (read-event))) com-char)
  831. (unless actions
  832. (setq actions ess-debug-error-action-alist))
  833. (setq act (pop actions))
  834. (ess-debug-set-error-action act)
  835. (force-mode-line-update)
  836. (message "On-error action set to: %s"
  837. (propertize (cadr act) 'face 'font-lock-function-name-face)))
  838. (push ev unread-command-events)))
  839. (defun ess--dbg-activate-overlays ()
  840. "Initialize active debug line overlays."
  841. (move-overlay ess--dbg-current-debug-overlay
  842. (point-at-bol) (1+ (point-at-eol)) (current-buffer))
  843. ;; used by overlay-arrow functionality on no-X, should be bol
  844. (move-marker ess--dbg-current-debug-position (point-at-bol)))
  845. (defun ess--dbg-deactivate-overlays ()
  846. "Deletes markers and overlays. Overlay arrow remains to indicate the last debug position."
  847. (delete-overlay ess--dbg-current-debug-overlay)
  848. (set-marker ess--dbg-current-debug-position nil))
  849. ;;;_ + Work Flow
  850. (defun ess-debug-goto-input-event-marker ()
  851. "Jump to the point where the last debugger/traceback etc event occurred.
  852. Mainly useful during/after debugging, to jump to the place
  853. from where the code was initially executed. This is an
  854. electric-command, which means that after the command is triggered a
  855. single key event is enough to navigate through the input-event-S-ring.
  856. If the key-event which triggered the command is Shift modified
  857. the input-event-S-ring is traversed backwards.
  858. The input-event-S-ring is a virtual object which consists of two
  859. rings `ess--dbg-forward-ring' and `ess--dbg-backward-ring' which
  860. are joint at their tops.
  861. See the more info at https://code.google.com/p/ess-tracebug/#Work-Flow"
  862. (interactive)
  863. (let* ((ev last-command-event)
  864. (com-char (event-basic-type ev))
  865. (ring-el 0)
  866. input-point)
  867. (if (memq 'shift (event-modifiers ev))
  868. (setq input-point (ring-ref ess--dbg-backward-ring 0))
  869. (ring-insert ess--dbg-backward-ring (point-marker)) ;; insert in backward ring ;;TODO: check if the marker to this (close by?) position is already in the ring
  870. (setq input-point (ring-ref ess--dbg-forward-ring 0)))
  871. (when (marker-buffer input-point) ;; TODO: give a message here if buff is not found
  872. (pop-to-buffer-same-window (marker-buffer input-point))
  873. (when (marker-position input-point)
  874. (goto-char (marker-position input-point))))
  875. (while (eq (event-basic-type (event-basic-type (setq ev (read-event)))) com-char)
  876. (if (memq 'shift (event-modifiers ev))
  877. (setq ring-el (1- ring-el))
  878. (setq ring-el (1+ ring-el)))
  879. (if (< ring-el 0)
  880. (setq input-point (ring-ref ess--dbg-backward-ring (- ring-el))) ;; get it from backward-ring
  881. ;; get it from forward-ring
  882. (setq input-point (ring-ref ess--dbg-forward-ring ring-el)) )
  883. (when (marker-buffer input-point)
  884. (pop-to-buffer-same-window (marker-buffer input-point))
  885. (when (marker-position input-point)
  886. (goto-char (marker-position input-point)))))
  887. (push ev unread-command-events)))
  888. (defun ess-debug-goto-debug-point ()
  889. "Return to the debugging position.
  890. Jump to markers stored in `ess--dbg-backward-ring'. If debug
  891. session is active, first jump to current debug line.
  892. This is an electric-command. Shift triggers the opposite traverse
  893. of the ring."
  894. (interactive)
  895. (let* ((debug-point (ring-ref ess--dbg-backward-ring 0))
  896. (ev last-command-event)
  897. (com-char (event-basic-type ev))
  898. (ring-el 0))
  899. (if (ess--dbg-is-active-p)
  900. (progn
  901. (pop-to-buffer-same-window (marker-buffer ess--dbg-current-debug-position))
  902. (goto-char (marker-position ess--dbg-current-debug-position ))
  903. (back-to-indentation))
  904. (pop-to-buffer-same-window (marker-buffer debug-point))
  905. (goto-char (marker-position debug-point)))
  906. (while (eq (event-basic-type (setq ev (read-event))) com-char)
  907. (if (memq 'shift (event-modifiers ev))
  908. (setq ring-el (1- ring-el))
  909. (setq ring-el (1+ ring-el)))
  910. (setq debug-point (ring-ref ess--dbg-backward-ring ring-el))
  911. (when (marker-buffer debug-point)
  912. (pop-to-buffer-same-window (marker-buffer debug-point))
  913. (when (marker-position debug-point)
  914. (goto-char (marker-position debug-point)))))
  915. (push ev unread-command-events)))
  916. (defun ess-debug-insert-in-forward-ring ()
  917. "Insert `point-marker' into the forward-ring."
  918. (interactive)
  919. (ring-insert ess--dbg-forward-ring (point-marker))
  920. (message "Point inserted into the forward-ring"))
  921. (defvar ess-debug-indicator " DB"
  922. "String to be displayed in mode-line alongside the process name.
  923. Indicates that ess-debug-mode is turned on. When the debugger is
  924. in active state this string is shown in upper case and
  925. highlighted.")
  926. (defvar-local ess--dbg-mode-line-debug
  927. '(:eval (let ((proc (get-process ess-local-process-name)))
  928. (if (and proc (process-get proc 'dbg-active))
  929. (let ((str ess-debug-indicator))
  930. (ess-debug-minor-mode 1) ; activate the keymap
  931. (put-text-property 1 (length str)
  932. 'face '(:foreground "white" :background "red")
  933. str)
  934. str)
  935. (ess-debug-minor-mode -1)
  936. ""))))
  937. (put 'ess--dbg-mode-line-debug 'risky-local-variable t)
  938. (defvar-local ess--dbg-mode-line-error-action
  939. '(:eval (or (and (ess-process-live-p)
  940. (ess-process-get 'on-error-action))
  941. "")))
  942. (put 'ess--dbg-mode-line-error-action 'risky-local-variable t)
  943. (defun ess--dbg-remove-empty-lines (string)
  944. "Remove empty lines from STRING (which interfere with evals) during debug.
  945. This function is placed in `ess-presend-filter-functions'."
  946. (if (and ess--dbg-del-empty-p (ess-process-get 'dbg-active))
  947. (replace-regexp-in-string "\n\\s *$" "" string)
  948. string))
  949. (defun ess-debug-start ()
  950. "Start the debug session.
  951. Add to ESS the interactive debugging functionality, breakpoints,
  952. watch and loggers. Integrates into ESS and iESS modes by binding
  953. `ess-tracebug-map' to `ess-tracebug-prefix' in
  954. `ess-mode-map' and `inferior-ess-mode-map' respectively."
  955. (interactive)
  956. (let ((dbuff (get-buffer-create (concat ess--dbg-output-buf-prefix "." ess-current-process-name "*"))) ;TODO: make dbuff a string!
  957. (proc (ess-get-process ess-local-process-name))
  958. (lpn ess-local-process-name))
  959. (process-put proc 'dbg-buffer dbuff); buffer were the look up takes place
  960. (process-put proc 'dbg-active nil) ; t if the process is in active debug state.
  961. ; Active debug states are usually those, in which prompt start with Browser[d]>
  962. (set-process-filter proc 'inferior-ess-tracebug-output-filter)
  963. (with-current-buffer (process-buffer proc)
  964. (unless (equal ess-dialect "R")
  965. (error "Can not activate the debugger for %s dialect" ess-dialect))
  966. (add-to-list 'ess--mode-line-process-indicator 'ess--dbg-mode-line-debug t)
  967. (add-to-list 'ess--mode-line-process-indicator 'ess--dbg-mode-line-error-action t)
  968. (add-hook 'ess-presend-filter-functions 'ess--dbg-remove-empty-lines nil 'local))
  969. (with-current-buffer dbuff
  970. (setq ess-local-process-name lpn)
  971. (buffer-disable-undo)
  972. ;; (setq buffer-read-only nil)
  973. (make-local-variable 'overlay-arrow-position) ;; indicator for next-error functionality in the *ess.dbg*, useful??
  974. (goto-char (point-max))
  975. (setq ess--dbg-buf-p t ;; true if in *ess.dbg* buffer
  976. ess--dbg-current-ref (point-marker) ;; used by goto-error functionality
  977. ess--dbg-last-ref-marker (point-marker) ;; gives marker to reference of the last debugged line
  978. )
  979. ;; (beginning-of-line)
  980. ;; (setq buffer-read-only t)
  981. )))
  982. (defun ess-debug-stop ()
  983. "End the debug session.
  984. Kill the *ess.dbg.[R_name]* buffer."
  985. ;;; process plist is not removed, TODO?low priority
  986. (interactive)
  987. (let ((proc (get-process ess-current-process-name))) ;;local?
  988. (with-current-buffer (process-buffer proc)
  989. (if (member ess-dialect '("XLS" "SAS" "STA"))
  990. (error "Can not deactivate the debugger for %s dialect" ess-dialect))
  991. (delq 'ess--dbg-mode-line-debug ess--mode-line-process-indicator)
  992. (delq 'ess--dbg-mode-line-error-action ess--mode-line-process-indicator)
  993. (remove-hook 'ess-presend-filter-functions 'ess--dbg-remove-empty-lines 'local))
  994. (set-process-filter proc 'inferior-ess-output-filter)
  995. (kill-buffer (process-get proc 'dbg-buffer))
  996. (process-put proc 'dbg-buffer nil)
  997. (process-put proc 'dbg-active nil)
  998. ;; (when (buffer-live-p ess--dbg-buffer)
  999. ;; ;; (with-current-buffer ess--dbg-buffer
  1000. ;; ;; (set-buffer-modified-p nil)
  1001. ;; ;; )
  1002. ;; (kill-buffer ess--dbg-buffer)
  1003. ;; )
  1004. ))
  1005. (defun ess--make-busy-timer-function (process)
  1006. "Display the spinner of prompt if PROCESS is busy."
  1007. `(lambda ()
  1008. (let ((pb ,process))
  1009. (when (eq (process-status pb) 'run) ;; only when the process is alive
  1010. (with-current-buffer (process-buffer pb)
  1011. (if (not (process-get pb 'busy)) ;; if ready
  1012. (when (> ess--busy-count 0)
  1013. (setq ess--busy-count 0)
  1014. (force-mode-line-update)
  1015. (redisplay))
  1016. (setq ess--busy-count (1+ (mod ess--busy-count (1- (length ess-busy-strings)))))
  1017. (force-mode-line-update)
  1018. (redisplay)))))))
  1019. ;; (ess--make-busy-prompt-function (get-process "R"))
  1020. (defun ess--dbg-is-active-p ()
  1021. "Return t if the current R process is in active debugging state."
  1022. (and (ess-process-live-p)
  1023. (ess-process-get 'dbg-active)))
  1024. (defun ess--dbg-is-recover-p ()
  1025. "Return t if the current R process is in active debugging state."
  1026. (and (ess-process-live-p)
  1027. (ess-process-get 'is-recover)))
  1028. (defun ess-debug-active-p (&optional proc)
  1029. (and (ess-process-live-p proc)
  1030. (or (ess-process-get 'dbg-active proc)
  1031. (ess-process-get 'is-recover proc))))
  1032. (defvar ess--dbg-regexp-reference "debug \\w+ +\\(.+\\)#\\([0-9]+\\):")
  1033. (defvar ess--dbg-regexp-jump "debug \\w+ ") ;; debug at ,debug bei ,etc
  1034. (defvar ess--dbg-regexp-skip
  1035. ;; don't anchor to bol; secondary prompt can occur before (anything else?)
  1036. ;; "\\(\\(?:Called from: \\)\\|\\(?:debugging in: \\)\\|\\(?:#[0-9]*: +recover()\\)\\)")
  1037. "\\(\\(?:Called from: \\)\\|\\(?:#[0-9]*: +recover()\\)\\)")
  1038. (defvar ess--dbg-regexp-no-skip
  1039. ;; exceptions for first skip (magrittr)
  1040. "debug_pipe")
  1041. (defvar ess--dbg-regexp-debug "\\(\\(?:Browse[][0-9]+\\)\\|\\(?:debug: \\)\\)")
  1042. (defvar ess--dbg-regexp-selection "\\(Selection: \\'\\)")
  1043. (defvar ess--dbg-regexp-input (concat ess--dbg-regexp-debug "\\|"
  1044. ess--dbg-regexp-selection))
  1045. (defvar ess--suppress-next-output? nil)
  1046. ;;; MPI
  1047. ;; http://jkorpela.fi/chars/c0.html
  1048. ;; https://en.wikipedia.org/wiki/ANSI_escape_code#Escape_sequences
  1049. (defvar ess-mpi-message-start-delimiter "_")
  1050. (defvar ess-mpi-message-field-separator "")
  1051. (defvar ess-mpi-message-end-delimiter "\\")
  1052. (define-obsolete-variable-alias 'ess-mpi-alist 'ess-mpi-handlers "ESS 19.04")
  1053. (defvar ess-mpi-handlers
  1054. '(("message" . message)
  1055. ("error" . ess-mpi:error)
  1056. ("eval" . ess-mpi:eval)
  1057. ("y-or-n" . ess-mpi:y-or-n))
  1058. "Alist of the MPI handlers.
  1059. Each element is of the form (TYPE . HANDLER), where TYPE is the
  1060. message type and HANDLER is a function (symbol) to be called on
  1061. the payload list of each message.")
  1062. (defun ess-mpi:error (msg)
  1063. (error "MPI error: %s" msg))
  1064. (defun ess-mpi:eval (str &optional callback)
  1065. "Read STR and evaluate as Emacs expression.
  1066. If present, the CALLBACK string is passed through `format' with
  1067. returned value from EXPR and then sent to the subprocess."
  1068. (let ((result (eval (read str))))
  1069. (when callback
  1070. (ess-send-string (ess-get-process) (format callback result)))))
  1071. (defun ess-mpi:y-or-n (prompt callback)
  1072. "Ask `y-or-n-p' with PROMPT.
  1073. The CALLBACK string is passed through `format' with returned
  1074. value from EXPR and then sent to the subprocess."
  1075. (let ((result (y-or-n-p prompt)))
  1076. (when callback
  1077. (let ((result (if result "TRUE" "FALSE")))
  1078. (ess-send-string (ess-get-process) (format callback result))))))
  1079. (defun ess-mpi-convert (el)
  1080. (cond
  1081. ((string= el "nil") nil)
  1082. ((string= el "t") t)
  1083. (t el)))
  1084. (defun ess-mpi-handle-messages (buf)
  1085. "Handle all mpi messages in BUF and delete them.
  1086. The MPI message has the form TYPEFIELD... where TYPE is the
  1087. type of the messages on which handlers in `ess-mpi-handlers' are
  1088. dispatched. And FIELDs are strings. Return :incomplete if BUF
  1089. ends with an incomplete message."
  1090. (let ((obuf (current-buffer))
  1091. (out nil))
  1092. (with-current-buffer buf
  1093. (goto-char (point-min))
  1094. ;; This should be smarter because Emacs might cut it in the middle of the
  1095. ;; message. In practice this almost never happen because we are
  1096. ;; accumulating output into the cache buffer.
  1097. (while (search-forward ess-mpi-message-start-delimiter nil t)
  1098. (let ((mbeg0 (match-beginning 0))
  1099. (mbeg (match-end 0)))
  1100. (if (search-forward ess-mpi-message-end-delimiter nil t)
  1101. (let* ((mend (match-beginning 0))
  1102. (mend0 (match-end 0))
  1103. (msg (buffer-substring mbeg mend))
  1104. (payload (mapcar #'ess-mpi-convert
  1105. (split-string msg ess-mpi-message-field-separator)))
  1106. (head (pop payload))
  1107. (handler (cdr (assoc head ess-mpi-handlers))))
  1108. (unwind-protect
  1109. (if handler
  1110. (with-current-buffer obuf
  1111. (apply handler payload))
  1112. (error "No handler defined for MPI message '%s" head))
  1113. (goto-char mbeg0)
  1114. (delete-region mbeg0 mend0)))
  1115. (setq out :incomplete))))
  1116. out)))
  1117. (defun ess--replace-long+-in-prompt (prompt is-final)
  1118. "Replace long + + + in PROMPT based on `inferior-ess-replace-long+' value.
  1119. If IS-FINAL means that PROMPT occurs at the end of the process
  1120. chunk. If non-nil, special care is taken not to drop last '+'
  1121. value as it might be a continuation prompt."
  1122. ;; see #576 for interesting input examples
  1123. (let ((len (length prompt)))
  1124. (if (or (null inferior-ess-replace-long+)
  1125. (< len 2))
  1126. prompt
  1127. (let ((last+ (eq (elt prompt (- len 2)) ?+)))
  1128. (cond
  1129. ((eq inferior-ess-replace-long+ 'strip)
  1130. (if (and last+ is-final)
  1131. "+ "
  1132. "> "))
  1133. ((eq inferior-ess-replace-long+ t)
  1134. (let ((prompt (replace-regexp-in-string "\\(\\+ \\)\\{2\\}\\(\\+ \\)+"
  1135. ess-long+replacement prompt)))
  1136. (if (and last+ (not is-final))
  1137. ;; append > for aesthetic reasons
  1138. (concat prompt "> ")
  1139. prompt)))
  1140. (t (error "Invalid values of `inferior-ess-replace-long+'")))))))
  1141. (defun ess--offset-output (prev-prompt str)
  1142. "Add suitable offset to STR given the preceding PREV-PROMPT."
  1143. (if prev-prompt
  1144. (let ((len (length prev-prompt)))
  1145. ;; prompts have at least 2 chars
  1146. (if (eq (elt prev-prompt (- len 2)) ?+)
  1147. ;; when last + append > for aesthetic reasons
  1148. (concat "> \n" str)
  1149. (if (eq (elt str 0) ?\n)
  1150. ;; don't insert empty lines
  1151. str
  1152. (concat "\n" str))))
  1153. str))
  1154. (defun ess--flush-accumulated-output (proc)
  1155. "Flush accumulated output of PROC into its output buffer.
  1156. Insertion happens chunk by chunk. A chunk is a region between two
  1157. prompts."
  1158. (let* ((abuf (ess--accumulation-buffer proc))
  1159. (pbuf (process-buffer proc))
  1160. (visibly (process-get proc :eval-visibly))
  1161. (nowait (eq visibly 'nowait))
  1162. (flush-timer (process-get proc 'flush-timer)))
  1163. (when (> (buffer-size abuf) 0)
  1164. (when (timerp flush-timer)
  1165. (cancel-timer flush-timer))
  1166. (if (eq (buffer-local-value 'major-mode pbuf) 'fundamental-mode)
  1167. ;; FIXME: this cannot be, ess-command changes the filter
  1168. ;; Just in case if we are in *ess-command* buffer; restart the timer.
  1169. (process-put proc 'flush-timer
  1170. (run-at-time .02 nil #'ess--flush-accumulated-output proc))
  1171. ;; Incomplete mpi should hardly happen. Only on those rare occasions
  1172. ;; when an mpi is issued after a long task and split by the Emacs input
  1173. ;; handler, or mpi printing itself takes very long.
  1174. (unless (eq :incomplete (ess-mpi-handle-messages abuf))
  1175. (with-current-buffer abuf
  1176. (goto-char (point-min))
  1177. (let ((case-fold-search nil))
  1178. (when (re-search-forward "Error\\(:\\| +in\\)" nil t)
  1179. (unless (get-buffer-window pbuf 'visible)
  1180. (display-buffer (process-buffer proc) nil t))))
  1181. (goto-char (point-min))
  1182. ;; First long + + in the output mirrors the sent input by the user and
  1183. ;; is unnecessary in nowait case. A single + can be a continuation in
  1184. ;; the REPL, thus we check if there is an extra output after the + .
  1185. (when nowait
  1186. (when (looking-at "\\([+>] \\)\\{2,\\}\n?")
  1187. (goto-char (match-end 0))
  1188. (when (eq (point) (point-max))
  1189. ;; if this is the last prompt in the output back-up one prompt
  1190. ;; (cannot happen after \n)
  1191. (backward-char 2))))
  1192. (let ((do-clean (not (eq visibly t)))
  1193. (pos2 (point))
  1194. (pos1 (point))
  1195. (tpos nil)
  1196. (prompt nil)
  1197. (regexp (if nowait
  1198. ;; we cannot disambiguate printed input fields and
  1199. ;; prompts in output in this case; match 2+ pluses or
  1200. ;; > and 2+ spaces
  1201. "\\(^\\([+>] \\)\\{2,\\}\\)\\|\\(> \\) +"
  1202. "^\\([+>] \\)+"))
  1203. (prev-prompt (process-get proc 'prev-prompt)))
  1204. (while (re-search-forward regexp nil t)
  1205. (setq pos1 (match-beginning 0)
  1206. tpos (if nowait
  1207. (or (match-end 1) (match-end 3))
  1208. (match-end 0)))
  1209. ;; for debugging in R:accum window in order to see the pointer moving
  1210. ;; (set-window-point (get-buffer-window) tpos)
  1211. (when (> pos1 pos2)
  1212. (let ((str (buffer-substring pos2 pos1)))
  1213. (comint-output-filter proc (ess--offset-output prev-prompt str))))
  1214. (setq pos2 tpos)
  1215. (setq prompt (let ((prompt (buffer-substring pos1 pos2)))
  1216. (if do-clean
  1217. (ess--replace-long+-in-prompt prompt (eq pos2 (point-max)))
  1218. prompt)))
  1219. ;; Cannot bypass this trivial call to comint-output-filter because
  1220. ;; external tools could rely on prompts (org-babel [#598] for
  1221. ;; example). Setting dummy regexp in order to avoid comint erasing
  1222. ;; this prompt which contrasts to how we output prompts in all
  1223. ;; other cases.
  1224. (with-current-buffer pbuf
  1225. (let ((comint-prompt-regexp "^$"))
  1226. (comint-output-filter proc prompt)))
  1227. (setq prev-prompt (and do-clean prompt)
  1228. pos1 pos2))
  1229. ;; insert last chunk if any
  1230. (unless (eq pos1 (point-max))
  1231. (let ((str (buffer-substring-no-properties pos1 (point-max))))
  1232. (comint-output-filter proc (ess--offset-output prev-prompt str))
  1233. (setq prev-prompt nil)))
  1234. (process-put proc 'prev-prompt prev-prompt)
  1235. (process-put proc 'flush-time (and (process-get proc 'busy)
  1236. (float-time)))
  1237. (erase-buffer))))))))
  1238. (defun inferior-ess-tracebug-output-filter (proc string)
  1239. "Standard output filter for the inferior ESS process.
  1240. When `ess-debug' is active, this is the filter. Call
  1241. `inferior-ess-output-filter'. Check for debug
  1242. reg-expressions (see `ess--dbg-regexp-debug',...), when found
  1243. puts iESS in the debugging state. If in debugging state, mirrors
  1244. the output into *ess.dbg* buffer."
  1245. (let* ((is-iess (or (derived-mode-p 'ess-watch-mode)
  1246. (derived-mode-p 'inferior-ess-mode)))
  1247. (pbuf (process-buffer proc))
  1248. (abuf (ess--accumulation-buffer proc))
  1249. (dbuff (process-get proc 'dbg-buffer))
  1250. (wbuff (get-buffer ess-watch-buffer))
  1251. (was-in-dbg (process-get proc 'dbg-active))
  1252. (was-in-recover (process-get proc 'is-recover))
  1253. (input-point (point-marker))
  1254. (match-jump (string-match ess--dbg-regexp-jump string))
  1255. (match-input (string-match ess--dbg-regexp-input string))
  1256. (match-selection (and match-input
  1257. (match-string 2 string))) ;; Selection:
  1258. (match-skip (and ess-debug-skip-first-call
  1259. (string-match ess--dbg-regexp-skip string)
  1260. (not (string-match ess--dbg-regexp-no-skip string))))
  1261. (match-dbg (or match-skip (and match-input (not match-selection))))
  1262. (is-ready (inferior-ess--set-status proc string))
  1263. (new-time (float-time))
  1264. (last-time (process-get proc 'flush-time))
  1265. (flush-timer (process-get proc 'flush-timer)))
  1266. ;; current-buffer is still the user's input buffer here
  1267. (ess--if-verbose-write-process-state proc string)
  1268. (inferior-ess-run-callback proc string)
  1269. (process-put proc 'is-recover match-selection)
  1270. (if (or (process-get proc 'suppress-next-output?)
  1271. ess--suppress-next-output?)
  1272. ;; works only for suppressing short output, enough for now (for callbacks)
  1273. (process-put proc 'suppress-next-output? nil)
  1274. (with-current-buffer abuf
  1275. (goto-char (point-max))
  1276. (insert string))
  1277. ;; cancel the timer each time we enter this filter
  1278. (when (timerp flush-timer)
  1279. (cancel-timer flush-timer)
  1280. (process-put proc 'flush-timer nil))
  1281. (unless last-time ;; don't flush for the first time
  1282. (setq last-time new-time)
  1283. (process-put proc 'flush-time new-time))
  1284. ;; flush periodically
  1285. (let ((fast-flush (or is-ready
  1286. ;; for the sake of ess-eval-linewise
  1287. (process-get proc 'sec-prompt))))
  1288. (if (or
  1289. ;; theoretically we should flush asynchronously in all cases but
  1290. ;; somewhat unexpectedly it introduces much more randomness during
  1291. ;; batch testing. TODO: flush directly for now and either remove or
  1292. ;; improve on the next refactoring iteration
  1293. fast-flush
  1294. (> (- new-time last-time) .5)
  1295. (bound-and-true-p edebug-mode)
  1296. ;; the flush is not getting called if the third party call
  1297. ;; accept-process-output in a loop (e.g. org-babel-execute-src-block)
  1298. (bound-and-true-p org-babel-current-src-block-location))
  1299. (ess--flush-accumulated-output proc)
  1300. ;; Setup new flush timer. Ideally also for fast-flush case in order to
  1301. ;; avoid detecting intermediate prompts as end-of-output prompts.
  1302. (let ((timeout (if fast-flush .01 .2)))
  1303. (process-put proc 'flush-timer
  1304. (run-at-time timeout nil #'ess--flush-accumulated-output proc))))))
  1305. ;; WATCH
  1306. (when (and is-ready wbuff) ;; refresh only if the process is ready and wbuff exists, (not only in the debugger!!)
  1307. (ess-watch-refresh-buffer-visibly wbuff))
  1308. ;; JUMP to line if debug expression was matched
  1309. (when match-jump
  1310. (with-current-buffer dbuff ;; insert string in *ess.dbg* buffer
  1311. (goto-char (point-max))
  1312. (insert (concat "|-" string "-|")))
  1313. (ess--dbg-goto-last-ref-and-mark dbuff is-iess))
  1314. ;; (with-current-buffer dbuff ;; un-comment to see the value of STRING just before debugger exists
  1315. ;; (let ((inhibit-read-only t))
  1316. ;; (goto-char (point-max))
  1317. ;; (insert (concat " ---\n " string "\n ---"))
  1318. ;; ))
  1319. ;; SKIP if needed
  1320. (when (and match-skip (not was-in-recover))
  1321. (process-send-string proc "n\n"))
  1322. ;; EXIT the debugger
  1323. (when (and was-in-dbg
  1324. (not (or match-jump match-dbg))
  1325. (or is-ready match-selection))
  1326. (ess--dbg-deactivate-overlays)
  1327. (process-put proc 'dbg-active nil)
  1328. ;; (message "|<-- exited debugging -->|")
  1329. (when wbuff
  1330. (ess-watch-refresh-buffer-visibly wbuff)))
  1331. ;; ACTIVATE the debugger if entered for the first time
  1332. (when (and (not was-in-dbg)
  1333. (not match-selection)
  1334. (or match-jump match-dbg))
  1335. (unless is-iess
  1336. (ring-insert ess--dbg-forward-ring input-point))
  1337. (process-put proc 'dbg-active t)
  1338. (message
  1339. (ess--debug-keys-message-string))
  1340. (unless match-jump
  1341. ;; no source reference, simply show the inferior
  1342. (display-buffer pbuf)))
  1343. (when match-selection ;(and (not was-in-recover) match-selection)
  1344. (ess-electric-selection t))))
  1345. (defvar ess-debug-minor-mode-map
  1346. (let ((map (make-sparse-keymap)))
  1347. (define-key map (kbd "M-C") #'ess-debug-command-continue)
  1348. (define-key map [(control meta ?C)] #'ess-debug-command-continue-multi)
  1349. (define-key map (kbd "M-N") #'ess-debug-command-next)
  1350. (define-key map [(control meta ?N)] #'ess-debug-command-next-multi)
  1351. (define-key map (kbd "M-Q") #'ess-debug-command-quit)
  1352. (define-key map (kbd "M-U") #'ess-debug-command-up)
  1353. map)
  1354. "Keymap active when ESS process is in debugging state.
  1355. \\{ess-debug-minor-mode-map}")
  1356. (define-minor-mode ess-debug-minor-mode
  1357. "Minor mode activated when ESS process is in debugging state."
  1358. :lighter nil
  1359. :keymap ess-debug-minor-mode-map)
  1360. (defun ess--dbg-goto-last-ref-and-mark (dbuff &optional other-window)
  1361. "Open the most recent debug reference, and set all the necessary marks and overlays.
  1362. It's called from `inferior-ess-tracebug-output-filter'. DBUFF
  1363. must be the *ess.dbg* buffer associated with the process. If
  1364. OTHER-WINDOW is non nil, attempt to open the location in a
  1365. different window."
  1366. (let (t-debug-position ref)
  1367. (with-current-buffer dbuff
  1368. (setq ref (ess--dbg-get-next-ref -1 (point-max) ess--dbg-last-ref-marker
  1369. ess--dbg-regexp-reference)) ; sets point at the end of found ref
  1370. (when ref
  1371. (move-marker ess--dbg-last-ref-marker (point-at-eol))
  1372. ;; each new step repositions the current-ref!
  1373. (move-marker ess--dbg-current-ref ess--dbg-last-ref-marker)))
  1374. (when ref
  1375. (let ((buf (apply 'ess--dbg-goto-ref other-window ref)))
  1376. (if buf
  1377. ;; if referenced buffer has been found, put overlays:
  1378. (with-current-buffer buf
  1379. (setq t-debug-position (copy-marker (point-at-bol)))
  1380. (if (equal t-debug-position ess--dbg-current-debug-position)
  1381. (progn ;; highlights the overlay for ess--dbg-blink-interval seconds
  1382. (overlay-put ess--dbg-current-debug-overlay 'face 'ess--dbg-blink-same-ref-face)
  1383. (run-with-timer ess-debug-blink-interval nil
  1384. (lambda ()
  1385. (overlay-put ess--dbg-current-debug-overlay 'face 'ess-debug-current-debug-line-face))))
  1386. ;; else
  1387. (ess--dbg-activate-overlays)))
  1388. ;;else, buffer is not found: highlight and give the corresponding message
  1389. (overlay-put ess--dbg-current-debug-overlay 'face 'ess--dbg-blink-ref-not-found-face)
  1390. (run-with-timer ess-debug-blink-interval nil
  1391. (lambda ()
  1392. (overlay-put ess--dbg-current-debug-overlay 'face 'ess-debug-current-debug-line-face)))
  1393. (message "Reference %s not found" (car ref)))))))
  1394. (defun ess--dbg-goto-ref (other-window file line &optional col)
  1395. "Opens the reference given by FILE, LINE and COL.
  1396. Try to open in a different window if OTHER-WINDOW is nil. Return
  1397. the buffer if found, or nil otherwise be found.
  1398. `ess--dbg-find-buffer' is used to find the FILE and open the
  1399. associated buffer. If FILE is nil return nil."
  1400. (let ((mrk (car (ess--dbg-create-ref-marker file line col)))
  1401. (lpn ess-local-process-name))
  1402. (when mrk
  1403. (let ((buf (marker-buffer mrk)))
  1404. (if (not other-window)
  1405. (pop-to-buffer-same-window buf)
  1406. (let ((this-frame (window-frame (get-buffer-window (current-buffer)))))
  1407. (display-buffer buf)
  1408. ;; simple save-frame-excursion
  1409. (unless (eq this-frame (window-frame (get-buffer-window buf t)))
  1410. (ess-select-frame-set-input-focus this-frame))))
  1411. ;; set or re-set to lpn as this is the process with debug session on
  1412. (with-current-buffer buf
  1413. (setq ess-local-process-name lpn)
  1414. (goto-char mrk)
  1415. (set-window-point (get-buffer-window buf) mrk))
  1416. buf))))
  1417. ;; temporary, hopefully org folks implement something similar
  1418. (defvar org-babel-tangled-file nil)
  1419. (declare-function org-babel-tangle-jump-to-org "ob-tangle.el")
  1420. (defun ess--dbg-create-ref-marker (file line &optional col)
  1421. "Create markers to the reference given by FILE, LINE and COL.
  1422. Return list of two markers MK-start and MK-end. MK-start is the
  1423. position of error. Mk-end is the end of the line where error
  1424. occurred. If buffer associated with FILE is not found, or line is
  1425. nil, or TB-INDEX is not found return nil."
  1426. (if (stringp line) (setq line (string-to-number line)))
  1427. (if (stringp col) (setq col (string-to-number col)))
  1428. (let* ((srcref (gethash file ess--srcrefs))
  1429. (file (replace-regexp-in-string "^\n" "" ;; hack for gnu regexp
  1430. (or (car srcref) file)))
  1431. (tb-index (cadr srcref))
  1432. (buffer (ess--dbg-find-buffer file))
  1433. pos)
  1434. (when (and buffer line)
  1435. (save-excursion
  1436. (with-current-buffer buffer
  1437. (save-restriction
  1438. (widen) ;; how does this behave in narrowed buffers? tothink:
  1439. (goto-char 1)
  1440. (setq pos (point))
  1441. (when tb-index
  1442. (while (and (not (eq tb-index (get-text-property pos 'tb-index)))
  1443. (setq pos (next-single-property-change pos 'tb-index)))))
  1444. (unless pos
  1445. ;; use beg position if index not found
  1446. (setq pos (nth 2 srcref)))
  1447. (when pos
  1448. (goto-char pos)
  1449. (forward-line (1- line))
  1450. (if col
  1451. (goto-char (+ (point-at-bol) col))
  1452. (back-to-indentation))
  1453. (when (bound-and-true-p org-babel-tangled-file)
  1454. (org-babel-tangle-jump-to-org))
  1455. (list (point-marker) (copy-marker (point-at-eol))))))))))
  1456. (defun ess--dbg-find-buffer (filename)
  1457. "Find a buffer for file FILENAME.
  1458. If FILENAME is not found at all, ask the user where to find it if
  1459. `ess--dbg-ask-for-file' is non-nil. Search the directories in
  1460. `ess-tracebug-search-path'."
  1461. (let ((dirs (append
  1462. (ess-r-package-source-dirs)
  1463. (cl-loop for d in ess-tracebug-search-path
  1464. append (ess-r-package--all-source-dirs d))))
  1465. buffer name)
  1466. (setq dirs (cons default-directory dirs)) ;; TODO: should be R working dir
  1467. ;; 1. search already open buffers for match (associated file might not even exist yet)
  1468. (cl-dolist (bf (buffer-list))
  1469. (with-current-buffer bf
  1470. (when (and buffer-file-name
  1471. (or (and (file-name-absolute-p filename)
  1472. (string-match (format "%s\\'" filename) buffer-file-name))
  1473. (equal filename (file-name-nondirectory buffer-file-name))))
  1474. (setq buffer bf)
  1475. (cl-return))))
  1476. ;; 2. The file name is absolute. Use its explicit directory as
  1477. ;; the first in the search path, and strip it from FILENAME.
  1478. (when (and (null buffer)
  1479. (file-name-absolute-p filename))
  1480. (setq filename (abbreviate-file-name (expand-file-name filename))
  1481. dirs (cons (file-name-directory filename) dirs)
  1482. filename (file-name-nondirectory filename)))
  1483. ;; 3. Now search the path.
  1484. (while (and (null buffer) dirs)
  1485. (let ((thisdir (pop dirs)))
  1486. (setq name (expand-file-name filename thisdir)
  1487. buffer (and (file-exists-p name)
  1488. (find-file-noselect name)))))
  1489. ;; 4. Ask for file if not found (tothink: maybe remove this part?)
  1490. (if (and (null buffer)
  1491. ess-debug-ask-for-file)
  1492. (save-excursion ;This save-excursion is probably not right.
  1493. (let* ((pop-up-windows t)
  1494. (name (read-file-name
  1495. (format "Find next line in (default %s): " filename)
  1496. nil filename t nil))
  1497. (origname name))
  1498. (cond
  1499. ((not (file-exists-p name))
  1500. (message "Cannot find file `%s'" name)
  1501. (ding) (sit-for 2))
  1502. ((and (file-directory-p name)
  1503. (not (file-exists-p
  1504. (setq name (expand-file-name filename name)))))
  1505. (message "No `%s' in directory %s" filename origname)
  1506. (ding) (sit-for 2))
  1507. (t
  1508. (setq buffer (find-file-noselect name)))))))
  1509. ;; nil if not found
  1510. buffer))
  1511. (defun ess--dbg-get-next-ref (n &optional pt BOUND REG nF nL nC)
  1512. "Move point to the next reference in the *ess.dbg* buffer.
  1513. Must be called from *ess.dbg* buffer.
  1514. It returns the reference in the form (file line col) /all strings/ ,
  1515. or NIL if not found . Prefix arg N says how many error messages
  1516. to move forwards (or backwards, if negative). Optional arg PT,
  1517. if non-nil, specifies the value of point to start looking for the
  1518. next message, default to (point). BOUND is the limiting position
  1519. of the search. REG is the regular expression to search with. nF
  1520. - sub-expression of REG giving the 'file'; defaults to 1. nL -
  1521. giving the 'line'; defaults to 2. nC - sub-expr giving the
  1522. 'column'; defaults to 3."
  1523. (unless ess--dbg-buf-p
  1524. (error "Not in *ess.dbg* buffer"))
  1525. (setq nF (or nF 1)
  1526. nL (or nL 2)
  1527. nC (or nC 3))
  1528. (or pt (setq pt (point)))
  1529. ;; (message "ess--dbg-last-ref-marker%s vs pt%s vs point-max%s" ess--dbg-last-ref-marker pt (point-max))
  1530. (goto-char pt)
  1531. (if (search-forward-regexp REG BOUND t n)
  1532. (list (match-string nF) (match-string-no-properties nL) (match-string-no-properties nC))
  1533. nil))
  1534. (defun ess--debug-keys-message-string (&optional map)
  1535. (let ((overriding-local-map (or map ess-debug-minor-mode-map)))
  1536. (substitute-command-keys
  1537. (mapconcat 'identity
  1538. '("(\\[ess-debug-command-continue])cont"
  1539. "(\\[ess-debug-command-continue-multi])cont-multi"
  1540. "(\\[ess-debug-command-next])next"
  1541. "(\\[ess-debug-command-next-multi])next-multi"
  1542. "(\\[ess-debug-command-up])up"
  1543. "(\\[ess-debug-command-quit])quit")
  1544. " "))))
  1545. (defun ess-electric-selection (&optional wait)
  1546. "Call commands defined in `ess-electric-selection-map'.
  1547. Single-key input commands are those, which once executed do not
  1548. require the prefix command for subsequent invocation.
  1549. If WAIT is t, wait for next input and ignore the keystroke which
  1550. triggered the command."
  1551. (interactive)
  1552. (ess--execute-electric-command ess-electric-selection-map
  1553. "Selection: " wait
  1554. (not (ess-process-get 'is-recover))))
  1555. (defun ess-debug-command-digit (&optional ev)
  1556. "Digit commands in selection mode.
  1557. If supplied, EV must be a proper key event or a string representing the digit."
  1558. (interactive)
  1559. (ess-force-buffer-current)
  1560. (unless (ess--dbg-is-recover-p)
  1561. (error "Recover is not active"))
  1562. (unless ev
  1563. (setq ev last-command-event))
  1564. (let* ((ev-char (if (stringp ev)
  1565. ev
  1566. (char-to-string (event-basic-type ev))))
  1567. (proc (get-process ess-current-process-name))
  1568. (mark-pos (marker-position (process-mark proc)))
  1569. (comint-prompt-read-only nil)
  1570. prompt depth)
  1571. (with-current-buffer (process-buffer proc)
  1572. (goto-char mark-pos)
  1573. (save-excursion
  1574. (when (re-search-backward "\\(?: \\|^\\)\\([0-9]+\\):[^\t]+Selection:" ess--tb-last-input t)
  1575. (setq depth (string-to-number (match-string 1)))
  1576. (when (> depth 9)
  1577. (setq ev-char (ess-completing-read "Selection" (mapcar 'number-to-string
  1578. (number-sequence depth 0 -1))
  1579. nil t ev-char nil)))))
  1580. (setq prompt (delete-and-extract-region (point-at-bol) mark-pos))
  1581. (insert (concat prompt ev-char "\n"))
  1582. (ess-send-string proc ev-char)
  1583. (move-marker (process-mark proc) (max-char)))))
  1584. (defun ess-debug-command-next ()
  1585. "Step next in debug mode.
  1586. Equivalent to 'n' at the R prompt."
  1587. (interactive)
  1588. (ess-force-buffer-current)
  1589. (unless (ess--dbg-is-active-p)
  1590. (error "Debugger is not active"))
  1591. (if (ess--dbg-is-recover-p)
  1592. (ess-send-string (ess-get-process) "0")
  1593. (ess-send-string (ess-get-process) "n")))
  1594. (defun ess-debug-command-next-multi (&optional N)
  1595. "Ask for N and step (n) N times in debug mode."
  1596. (interactive)
  1597. (ess-force-buffer-current)
  1598. (unless (ess--dbg-is-active-p)
  1599. (error "Debugger is not active"))
  1600. (let ((N (or N (read-number "Number of steps: " 10)))
  1601. (ess--suppress-next-output? t))
  1602. (while (and (ess--dbg-is-active-p) (> N 0))
  1603. (ess-debug-command-next)
  1604. (ess-wait-for-process)
  1605. (setq N (1- N))))
  1606. (ess-debug-command-next))
  1607. (defun ess-debug-command-continue-multi (&optional N)
  1608. "Ask for N, and continue (c) N times in debug mode."
  1609. (interactive)
  1610. (ess-force-buffer-current)
  1611. (unless (ess--dbg-is-active-p)
  1612. (error "Debugger is not active"))
  1613. (let ((N (or N (read-number "Number of continuations: " 10)))
  1614. (ess--suppress-next-output? t))
  1615. (while (and (ess--dbg-is-active-p) (> N 1))
  1616. (ess-debug-command-continue)
  1617. (ess-wait-for-process)
  1618. (setq N (1- N))))
  1619. (ess-debug-command-continue))
  1620. (defun ess-debug-command-up ()
  1621. "Step up one call frame.
  1622. Equivalent to 'n' at the R prompt."
  1623. (interactive)
  1624. (ess-force-buffer-current)
  1625. (unless (ess--dbg-is-active-p)
  1626. (error "Debugger is not active"))
  1627. (let ((up-cmd "try(browserSetDebug(), silent=T)\nc\n"))
  1628. (ess-send-string (ess-get-process) up-cmd)))
  1629. ;; (defun ess-debug-previous-error (&optional ev)
  1630. ;; "Go to previous reference during the debug process.
  1631. ;; R doesn't support step backwards. This command just takes you through
  1632. ;; debug history."
  1633. ;; (interactive)
  1634. ;; (previous-error))
  1635. (defun ess-debug-command-quit ()
  1636. "Quits the browser/debug in R process.
  1637. Equivalent of `Q' at the R prompt."
  1638. (interactive)
  1639. (ess-force-buffer-current)
  1640. (cond ((ess--dbg-is-recover-p)
  1641. (ess-send-string (ess-get-process) "0" t))
  1642. ;; if recover is called in a loop the following stalls Emacs
  1643. ;; (ess-wait-for-process proc nil 0.05)
  1644. ((ess--dbg-is-active-p)
  1645. (ess-send-string (ess-get-process) "Q" t))
  1646. (t
  1647. (error "Debugger is not active"))))
  1648. (defun ess-debug-command-continue ()
  1649. "Continue the code execution.
  1650. Equivalent of `c' at the R prompt."
  1651. (interactive)
  1652. (ess-force-buffer-current)
  1653. (cond ((ess--dbg-is-recover-p)
  1654. (ess-send-string (ess-get-process) "0"))
  1655. ((ess--dbg-is-active-p)
  1656. (ess-send-string (ess-get-process) "c"))
  1657. (t
  1658. (error "Debugger is not active"))))
  1659. (defun ess-tracebug-set-last-input (&rest _args)
  1660. "Move `ess--tb-last-input' marker to the process mark.
  1661. ARGS are ignored to allow using this function in process hooks."
  1662. (let* ((last-input-process (get-process ess-local-process-name))
  1663. (last-input-mark (copy-marker (process-mark last-input-process))))
  1664. (with-current-buffer (process-buffer last-input-process)
  1665. (when (local-variable-p 'ess--tb-last-input) ;; TB might not be active in all processes
  1666. (save-excursion
  1667. (setq ess--tb-last-input last-input-mark)
  1668. (goto-char last-input-mark)
  1669. (inferior-ess-move-last-input-overlay))))))
  1670. ;;;_ + BREAKPOINTS
  1671. (defface ess-bp-fringe-inactive-face
  1672. '((((class color) (background light) (min-colors 88)) (:foreground "DimGray"))
  1673. (((class color) (background dark) (min-colors 88)) (:foreground "LightGray"))
  1674. (((background light) (min-colors 8)) (:foreground "blue"))
  1675. (((background dark) (min-colors 8)) (:foreground "cyan")))
  1676. "Face used to highlight inactive breakpoints."
  1677. :group 'ess-debug)
  1678. (defface ess-bp-fringe-logger-face
  1679. '((((class color) (background light) (min-colors 88)) (:foreground "dark red"))
  1680. (((class color) (background dark) (min-colors 88)) (:foreground "tomato1"))
  1681. (((background light) (min-colors 8)) (:foreground "blue"))
  1682. (((background dark) (min-colors 8)) (:foreground "cyan")))
  1683. "Face used to highlight loggers."
  1684. :group 'ess-debug)
  1685. (defface ess-bp-fringe-browser-face
  1686. '((((class color) (background light) (min-colors 88)) (:foreground "medium blue"))
  1687. (((class color) (background dark) (min-colors 88)) (:foreground "deep sky blue"))
  1688. (((background light) (min-colors 8)) (:foreground "blue"))
  1689. (((background dark) (min-colors 8)) (:foreground "cyan")))
  1690. "Face used to highlight 'browser' breakpoints."
  1691. :group 'ess-debug)
  1692. (defface ess-bp-fringe-recover-face
  1693. '((((class color) (background light) (min-colors 88)) (:foreground "dark magenta"))
  1694. (((class color) (background dark) (min-colors 88)) (:foreground "magenta"))
  1695. (((background light) (min-colors 8)) (:foreground "magenta"))
  1696. (((background dark) (min-colors 8)) (:foreground "magenta")))
  1697. "Face used to highlight 'recover' breakpoints fringe."
  1698. :group 'ess-debug)
  1699. (defun ess--bp-pipe-block-p ()
  1700. (save-excursion
  1701. (let ((inhibit-point-motion-hooks t)
  1702. (inhibit-field-text-motion t))
  1703. (forward-line -1)
  1704. (end-of-line)
  1705. (looking-back "%>%[ \t]*" (point-at-bol)))))
  1706. (defvar ess--bp-identifier 1)
  1707. (defcustom ess-bp-type-spec-alist
  1708. '((pipe ".ess_pipe_browser() %%>%%" "B %>%\n" filled-square ess-bp-fringe-browser-face ess--bp-pipe-block-p)
  1709. (browser "browser(expr=is.null(.ESSBP.[[%s]]));" "B>\n" filled-square ess-bp-fringe-browser-face)
  1710. (recover "recover()" "R>\n" filled-square ess-bp-fringe-recover-face))
  1711. "List of lists of breakpoint types.
  1712. Each sublist has five elements:
  1713. 1- symbol giving the name of specification
  1714. 2- R expression to be inserted (%s is substituted with unique identifier).
  1715. 3- string to be displayed instead of the expression
  1716. 4- fringe bitmap to use
  1717. 5- face for fringe and displayed string
  1718. 6- optional, a function which should return nil if this BP doesn't apply to current context."
  1719. :group 'ess-debug
  1720. :type '(alist :key-type symbol
  1721. :value-type (group string string symbol face)))
  1722. (defcustom ess-bp-inactive-spec
  1723. '(inactive "##" filled-square ess-bp-fringe-inactive-face)
  1724. "List giving the inactive breakpoint specifications."
  1725. ;; List format is identical to that of the elements of
  1726. ;; `ess-bp-type-spec-alist' except that the second element giving
  1727. ;; the R expression is meaningless here." ;;fixme: second element is missing make it nil for consistency with all other specs
  1728. :group 'ess-debug
  1729. :type 'list)
  1730. (defcustom ess-bp-conditional-spec
  1731. '(conditional "browser(expr={%s})" "CB[ %s ]>\n" question-mark ess-bp-fringe-browser-face)
  1732. "List giving the conditional breakpoint specifications.
  1733. List format is identical to that of the elements of
  1734. `ess-bp-type-spec-alist'. User is asked for the conditional
  1735. expression to be replaced instead of %s in the second and third
  1736. elements of the specifications."
  1737. :group 'ess-debug
  1738. :type 'list)
  1739. (defcustom ess-bp-logger-spec
  1740. '(logger ".ess_log_eval('%s')" "L[ \"%s\" ]>\n" hollow-square ess-bp-fringe-logger-face)
  1741. "List giving the loggers specifications.
  1742. List format is identical to that of `ess-bp-type-spec-alist'."
  1743. :group 'ess-debug
  1744. :type 'list)
  1745. (defun ess-bp-get-bp-specs (type &optional condition no-error)
  1746. "Get specs for TYPE."
  1747. (let ((spec-alist (cond
  1748. ((eq type 'conditional)
  1749. (let ((tl (copy-sequence ess-bp-conditional-spec)))
  1750. (when (eq (length condition) 0)
  1751. (setq condition "TRUE"))
  1752. (setcar (cdr tl) (format (cadr tl) condition))
  1753. (setcar (cddr tl) (format (caddr tl) condition))
  1754. (list tl)))
  1755. ((eq type 'logger)
  1756. (let ((tl (copy-sequence ess-bp-logger-spec)))
  1757. (when (eq (length condition) 0)
  1758. (setq condition "watchLog"))
  1759. (setcar (cdr tl) (format (cadr tl) condition))
  1760. (setcar (cddr tl) (format (caddr tl) condition))
  1761. (list tl)))
  1762. (t (copy-sequence ess-bp-type-spec-alist)))))
  1763. (or (assoc type spec-alist)
  1764. (if no-error
  1765. nil
  1766. (error "Undefined breakpoint type %s" type)))))
  1767. (defun ess-bp-create (type &optional condition no-error)
  1768. "Set breakpoint for the current line.
  1769. Returns the beginning position of the hidden text."
  1770. (let* ((bp-specs (ess-bp-get-bp-specs type condition no-error))
  1771. (init-pos (point-marker))
  1772. (fringe-bitmap (nth 3 bp-specs))
  1773. (fringe-face (nth 4 bp-specs))
  1774. (displ-string (nth 2 bp-specs))
  1775. (bp-id (format "\"@%s@\""
  1776. (setq ess--bp-identifier (1+ ess--bp-identifier))))
  1777. (bp-command (concat (format (nth 1 bp-specs) bp-id)
  1778. "##:ess-bp-end:##\n"))
  1779. (dummy-string (format "##:ess-bp-start::%s@%s:##\n" (car bp-specs) condition))
  1780. insertion-pos)
  1781. (when bp-specs
  1782. (set-marker init-pos (1+ init-pos))
  1783. (setq displ-string (propertize displ-string
  1784. 'face fringe-face
  1785. 'font-lock-face fringe-face))
  1786. (setq bp-command (propertize bp-command
  1787. 'ess-bp t
  1788. 'bp-id bp-id
  1789. 'bp-active t
  1790. 'cursor-intangible 'ess-bp
  1791. 'rear-nonsticky '(cursor-intangible ess-bp bp-type)
  1792. 'bp-type type
  1793. 'bp-substring 'command
  1794. 'display displ-string))
  1795. (setq dummy-string (propertize
  1796. (ess-tracebug--propertize dummy-string fringe-bitmap fringe-face "*")
  1797. 'ess-bp t
  1798. 'cursor-intangible 'ess-bp
  1799. 'bp-type type
  1800. 'bp-substring 'dummy))
  1801. (ess-tracebug--set-left-margin)
  1802. (back-to-indentation)
  1803. (setq insertion-pos (point) )
  1804. (insert (concat dummy-string bp-command))
  1805. (indent-for-tab-command)
  1806. (goto-char (1- init-pos)) ;; sort of save-excursion
  1807. insertion-pos)))
  1808. (defun ess-bp-recreate-all ()
  1809. "Internal function to recreate all bp."
  1810. (save-excursion
  1811. (save-restriction
  1812. (with-silent-modifications
  1813. (cursor-intangible-mode)
  1814. (widen)
  1815. (goto-char (point-min))
  1816. (while (re-search-forward
  1817. "\\(##:ess-bp-start::\\(.*\\):##\n\\)\\(.+##:ess-bp-end:##\n\\)" nil t)
  1818. (let ((dum-beg (match-beginning 1))
  1819. (dum-end (match-end 1))
  1820. (comm-beg (match-beginning 3))
  1821. (comm-end (match-end 3))
  1822. (type (match-string 2))
  1823. (bp-command (match-string 3))
  1824. bp-id dum-props condition)
  1825. (when (string-match "^\\(\\w+\\)@\\(.*\\)\\'" type)
  1826. (setq condition (match-string 2 type))
  1827. (setq type (match-string 1 type)))
  1828. (setq bp-id
  1829. (if (string-match "\"@[0-9]+@\"" bp-command)
  1830. (match-string 0 bp-command)
  1831. (setq ess--bp-identifier (1+ ess--bp-identifier))))
  1832. (setq type (intern type))
  1833. (let* ((bp-specs (ess-bp-get-bp-specs type condition t))
  1834. (displ-string (nth 2 bp-specs))
  1835. (fringe-face (nth 4 bp-specs))
  1836. (fringe-bitmap (nth 3 bp-specs)))
  1837. (when bp-specs
  1838. (setq displ-string (propertize displ-string
  1839. 'face fringe-face
  1840. 'font-lock-face fringe-face))
  1841. (add-text-properties comm-beg comm-end
  1842. (list 'ess-bp t
  1843. 'bp-id bp-id
  1844. 'cursor-intangible 'ess-bp
  1845. 'rear-nonsticky '(cursor-intangible ess-bp bp-type)
  1846. 'bp-type type
  1847. 'bp-substring 'command
  1848. 'display displ-string))
  1849. (setq dum-props
  1850. (if window-system
  1851. (list 'display (list 'left-fringe fringe-bitmap fringe-face))
  1852. (list 'display (list '(margin left-margin)
  1853. (propertize "dummy"
  1854. 'font-lock-face fringe-face
  1855. 'face fringe-face)))))
  1856. (add-text-properties dum-beg dum-end
  1857. (append dum-props
  1858. (list 'ess-bp t
  1859. 'cursor-intangible 'ess-bp
  1860. 'bp-type type
  1861. 'bp-substring 'dummy)))
  1862. ;; (when comment-beg
  1863. ;; (add-text-properties comment-beg comment-end
  1864. ;; (list 'ess-bp t
  1865. ;; 'bp-id bp-id
  1866. ;; 'cursor-intangible 'ess-bp
  1867. ;; 'display (propertize (nth 1 ess-bp-inactive-spec) 'face fringe-face)
  1868. ;; 'bp-type type
  1869. ;; 'bp-substring 'comment)))
  1870. ))))))))
  1871. (add-hook 'ess-r-mode-hook 'ess-bp-recreate-all)
  1872. (defun ess-bp-get-bp-position-nearby ()
  1873. "Get nearby break points.
  1874. Return the cons (beg . end) of breakpoint limit points closest to
  1875. the current position. Only currently visible region of the buffer
  1876. is searched. This command is intended for use in interactive
  1877. commands like `ess-bp-toggle-state' and `ess-bp-kill'. Use
  1878. `ess-bp-previous-position' in programs."
  1879. (interactive)
  1880. (let* ((pos-end (if (get-char-property (1- (point)) 'ess-bp)
  1881. (point)
  1882. (previous-single-property-change (point) 'ess-bp nil (window-start))))
  1883. (pos-start (if (get-char-property (point) 'ess-bp) ;;check for bobp
  1884. (point)
  1885. (next-single-property-change (point) 'ess-bp nil (window-end))))
  1886. dist-up dist-down)
  1887. (unless (eq pos-end (window-start))
  1888. (setq dist-up (- (line-number-at-pos (point))
  1889. (line-number-at-pos pos-end))))
  1890. (unless (eq pos-start (window-end))
  1891. (setq dist-down (- (line-number-at-pos pos-start)
  1892. (line-number-at-pos (point)))))
  1893. (if (and dist-up dist-down)
  1894. (if (< dist-up dist-down)
  1895. (cons (previous-single-property-change pos-end 'ess-bp nil (window-start)) pos-end)
  1896. (cons pos-start (next-single-property-change pos-start 'ess-bp nil (window-end))))
  1897. (if dist-up
  1898. (cons (previous-single-property-change pos-end 'ess-bp nil (window-start)) pos-end)
  1899. (if dist-down
  1900. (cons pos-start (next-single-property-change pos-start 'ess-bp nil (window-end))))))))
  1901. (defun ess-bp-previous-position ()
  1902. "Get previous breakpoints.
  1903. Return the cons (beg . end) of breakpoint limit points closest
  1904. to the current position, nil if not found."
  1905. (let* ( (pos-end (if (get-char-property (1- (point)) 'ess-bp)
  1906. (point)
  1907. (previous-single-property-change (point) 'ess-bp ))))
  1908. (if pos-end
  1909. (cons (previous-single-property-change pos-end 'ess-bp) pos-end))))
  1910. (defun ess-bp-set ()
  1911. "Set a breakpoint."
  1912. (interactive)
  1913. (let* ((pos (ess-bp-get-bp-position-nearby))
  1914. (same-line (and pos
  1915. (<= (point-at-bol) (cdr pos))
  1916. (>= (point-at-eol) (car pos))))
  1917. (types ess-bp-type-spec-alist)
  1918. (ev last-command-event)
  1919. (com-char (event-basic-type ev))
  1920. bp-type)
  1921. (when same-line
  1922. ;; set bp-type to next type in types
  1923. (setq bp-type (get-text-property (car pos) 'bp-type))
  1924. (setq types (cdr (member (assq bp-type types) types))) ; nil if bp-type is last in the list
  1925. (when (null types)
  1926. (setq types ess-bp-type-spec-alist))
  1927. (ess-bp-kill)
  1928. (indent-for-tab-command))
  1929. ;; skip contextual bps
  1930. (while (and (nth 5 (car types))
  1931. (not (funcall (nth 5 (car types)))))
  1932. (pop types))
  1933. (setq bp-type (pop types))
  1934. (ess-bp-create (car bp-type))
  1935. (while (eq (event-basic-type (setq ev (read-event (format "'%c' to cycle" com-char))))
  1936. com-char)
  1937. (if (null types) (setq types ess-bp-type-spec-alist))
  1938. (ess-bp-kill)
  1939. ;; skip contextual bps
  1940. (while (and (nth 5 (car types))
  1941. (not (funcall (nth 5 (car types)))))
  1942. (pop types))
  1943. (setq bp-type (pop types))
  1944. (ess-bp-create (car bp-type))
  1945. (indent-for-tab-command))
  1946. (push ev unread-command-events)))
  1947. (defun ess-bp-set-conditional (condition)
  1948. (interactive "sBreakpoint condition: ")
  1949. (ess-bp-create 'conditional condition)
  1950. (indent-for-tab-command))
  1951. (defun ess-bp-set-logger (name)
  1952. (interactive "sLogger name : ")
  1953. (ess-bp-create 'logger name)
  1954. (indent-for-tab-command))
  1955. (defun ess-bp-kill (&optional interactive?)
  1956. "Remove the breakpoint nearby."
  1957. (interactive "p")
  1958. (let ((pos (ess-bp-get-bp-position-nearby))
  1959. (init-pos (make-marker)))
  1960. (if (null pos)
  1961. (if interactive? (message "No breakpoints nearby"))
  1962. (if (eq (point) (point-at-eol))
  1963. (goto-char (1- (point)))) ;; work-around for issue 3
  1964. (set-marker init-pos (point))
  1965. (goto-char (car pos))
  1966. (delete-region (car pos) (cdr pos))
  1967. (indent-for-tab-command)
  1968. (goto-char init-pos)
  1969. (if (eq (point) (point-at-eol)) (forward-char)))))
  1970. (defun ess-bp-kill-all nil
  1971. "Delete all breakpoints in current buffer."
  1972. (interactive)
  1973. (let ((count 0)
  1974. (init-pos (make-marker))
  1975. pos)
  1976. (set-marker init-pos (1+ (point)))
  1977. (save-excursion ;; needed if error
  1978. (goto-char (point-max))
  1979. (while (setq pos (ess-bp-previous-position))
  1980. (goto-char (car pos))
  1981. (delete-region (car pos) (cdr pos))
  1982. (indent-for-tab-command)
  1983. (setq count (1+ count)))
  1984. (if (eq count 1)
  1985. (message "Killed 1 breakpoint")
  1986. (message "Killed %d breakpoint(s)" count)))
  1987. (goto-char (1- init-pos))))
  1988. (defun ess-bp-toggle-state ()
  1989. "Toggle the breakpoint between active and inactive states.
  1990. For standard breakpoints, the effect of this command is
  1991. immediate, that is you don't need to source your code and it
  1992. works even in the process of debugging.
  1993. For loggers, recover and conditional breakpoints this command
  1994. just comments the breakpoint in the source file.
  1995. If there is no active R session, this command triggers an error."
  1996. (interactive)
  1997. (unless (and ess-local-process-name
  1998. (get-process ess-local-process-name))
  1999. (error "No R session in this buffer"))
  2000. (save-excursion
  2001. (let ((pos (ess-bp-get-bp-position-nearby))
  2002. (fringe-face (nth 3 ess-bp-inactive-spec))
  2003. (cursor-sensor-inhibit 'ess-bp-toggle-state)
  2004. bp-id bp-specs beg-pos-command)
  2005. (if (null pos)
  2006. (message "No breakpoints in the visible region")
  2007. (goto-char (car pos))
  2008. (setq beg-pos-command (previous-single-property-change
  2009. (cdr pos) 'bp-substring nil (car pos))
  2010. bp-id (get-char-property beg-pos-command 'bp-id))
  2011. (goto-char beg-pos-command)
  2012. (if (get-char-property beg-pos-command 'bp-active)
  2013. (progn
  2014. (put-text-property (car pos) beg-pos-command ;; dummy display change
  2015. 'display (list 'left-fringe (nth 2 ess-bp-inactive-spec) fringe-face))
  2016. (put-text-property beg-pos-command (cdr pos)
  2017. 'bp-active nil)
  2018. (ess-command (format ".ESSBP.[[%s]] <- TRUE\n" bp-id)))
  2019. (setq bp-specs (assoc (get-text-property (point) 'bp-type) ess-bp-type-spec-alist))
  2020. (put-text-property beg-pos-command (cdr pos)
  2021. 'bp-active t)
  2022. (put-text-property (car pos) beg-pos-command
  2023. 'display (list 'left-fringe (nth 3 bp-specs) (nth 4 bp-specs)))
  2024. (ess-command (format ".ESSBP.[[%s]] <- NULL\n" bp-id))
  2025. ;; (insert (propertize "##"
  2026. ;; 'ess-bp t
  2027. ;; 'cursor-intangible 'ess-bp
  2028. ;; 'display (propertize (nth 1 ess-bp-inactive-spec) 'face fringe-face)
  2029. ;; 'bp-type (get-char-property (point) 'bp-type)
  2030. ;; 'bp-substring 'comment))
  2031. )))))
  2032. (defun ess-bp-make-visible ()
  2033. "Make bp text visible."
  2034. (interactive)
  2035. (let ((pos (ess-bp-get-bp-position-nearby)))
  2036. (set-text-properties (car pos) (cdr pos) (list 'display nil))))
  2037. (defun ess-bp-next nil
  2038. "Goto next breakpoint."
  2039. (interactive)
  2040. (when-let ((bp-pos (next-single-property-change (point) 'ess-bp)))
  2041. (save-excursion
  2042. (goto-char bp-pos)
  2043. (when (get-text-property (1- (point)) 'ess-bp)
  2044. (setq bp-pos (next-single-property-change bp-pos 'ess-bp))))
  2045. (if bp-pos
  2046. (goto-char bp-pos)
  2047. (message "No breakpoints found"))))
  2048. (defun ess-bp-previous nil
  2049. "Goto previous breakpoint."
  2050. (interactive)
  2051. (if-let ((bp-pos (previous-single-property-change (point) 'ess-bp)))
  2052. (goto-char (or (previous-single-property-change bp-pos 'ess-bp)
  2053. bp-pos))
  2054. (message "No breakpoints before the point found")))
  2055. ;;;_ + WATCH
  2056. (defvar ess-watch-command
  2057. ;; assumes that every expression is a structure of length 1 as returned by parse.
  2058. ".ess_watch_eval()\n")
  2059. (if (fboundp 'define-fringe-bitmap) ;;not clear to me why is this not bound in SSH session? - :TODO check
  2060. (define-fringe-bitmap 'current-watch-bar
  2061. [#b00001100] nil nil '(top t)))
  2062. (defun ess-tracebug--set-left-margin ()
  2063. "Set the margin on non-X displays."
  2064. (unless window-system
  2065. (when (= left-margin-width 0)
  2066. (setq left-margin-width 1)
  2067. (set-window-buffer (selected-window) (current-buffer)))))
  2068. (define-derived-mode ess-watch-mode special-mode "ESS watch"
  2069. "Major mode in `ess-watch' window."
  2070. :group 'ess-tracebug
  2071. (let ((cur-block (max 1 (ess-watch-block-at-point)))
  2072. (dummy-string
  2073. (ess-tracebug--propertize "|" 'current-watch-bar 'font-lock-keyword-face)))
  2074. (ess-tracebug--set-left-margin)
  2075. (setq-local revert-buffer-function 'ess-watch-revert-buffer)
  2076. (turn-on-font-lock)
  2077. (setq ess-watch-current-block-overlay
  2078. (make-overlay (point-min) (point-max)))
  2079. (overlay-put ess-watch-current-block-overlay 'line-prefix dummy-string)
  2080. (overlay-put ess-watch-current-block-overlay 'face 'ess-watch-current-block-face)
  2081. (ess-watch-set-current cur-block) ;;
  2082. (require 'face-remap)
  2083. ;; scale the font
  2084. (setq text-scale-mode-amount ess-watch-scale-amount)
  2085. (text-scale-mode)))
  2086. (defun ess-watch ()
  2087. "Run `ess-watch-mode' on R objects.
  2088. This is the trigger function. See documentation of
  2089. `ess-watch-mode' for more information."
  2090. (interactive)
  2091. (ess-force-buffer-current)
  2092. (let ((wbuf (get-buffer-create ess-watch-buffer))
  2093. (pname ess-local-process-name))
  2094. (pop-to-buffer wbuf
  2095. ;; not strongly dedicated
  2096. '(nil . ((dedicated . 1))))
  2097. (setq ess-local-process-name pname)
  2098. (ess-watch-mode)
  2099. ;; evals the ess-command and displays the buffer if not visible
  2100. (ess-watch-refresh-buffer-visibly wbuf)))
  2101. (defun ess-watch-refresh-buffer-visibly (wbuf &optional sleep no-prompt-check)
  2102. "Eval `ess-watch-command' and direct the output into the WBUF.
  2103. Call `ess-watch-buffer-show' to make the buffer visible, without
  2104. selecting it. SLEEP and NO-PROMPT-CHECK get passed to `ess-command'.
  2105. This function is used for refreshing the watch window after each step during
  2106. the debugging."
  2107. ;; assumes that the ess-watch-mode is on!!
  2108. ;; particularly ess-watch-current-block-overlay is installed
  2109. (ess-watch-buffer-show wbuf) ;; if visible do nothing
  2110. (let ((pname ess-local-process-name)) ;; watch might be used from different dialects, need to reset
  2111. (with-current-buffer wbuf
  2112. (let ((curr-block (max 1 (ess-watch-block-at-point))) ;;can be 0 if
  2113. (inhibit-read-only t))
  2114. (when pname
  2115. (setq ess-local-process-name pname))
  2116. (ess-command ess-watch-command wbuf sleep no-prompt-check)
  2117. ;; delete the ++++++> line ;; not very reliable but works fine so far.
  2118. (goto-char (point-min))
  2119. (delete-region (point-at-bol) (+ 1 (point-at-eol)))
  2120. (ess-watch-set-current curr-block)
  2121. (set-window-point (get-buffer-window wbuf) (point))))))
  2122. (defun ess-watch-buffer-show (buffer-or-name)
  2123. "Make watch buffer BUFFER-OR-NAME visible, and position accordingly.
  2124. If already visible, do nothing.
  2125. Currently the only positioning rule implemented is to split the R
  2126. process window in half. The behavior is controlled by
  2127. `split-window-sensibly' with parameters `split-height-threshold'
  2128. and `split-width-threshold' replaced by
  2129. `ess-watch-height-threshold' and `ess-watch-width-threshold'
  2130. respectively."
  2131. (interactive)
  2132. (unless (get-buffer-window ess-watch-buffer 'visible)
  2133. (save-selected-window
  2134. (ess-switch-to-ESS t)
  2135. (let* ((split-width-threshold (or ess-watch-width-threshold
  2136. split-width-threshold))
  2137. (split-height-threshold (or ess-watch-height-threshold
  2138. split-height-threshold))
  2139. (win (split-window-sensibly (selected-window))))
  2140. (if win
  2141. (set-window-buffer win buffer-or-name)
  2142. (display-buffer buffer-or-name) ;; resort to usual mechanism if could not split
  2143. )))))
  2144. (defun ess-watch-revert-buffer (_ignore _noconfirm)
  2145. "Update the watch buffer.
  2146. Arguments IGNORE and NOCONFIRM currently not used."
  2147. (ess-watch)
  2148. (message "Watch reverted"))
  2149. (defface ess-watch-current-block-face
  2150. '((default (:inherit highlight)))
  2151. "Face used to highlight current watch block."
  2152. :group 'ess-debug)
  2153. (defvar ess-watch-start-block "@----" ;; fixme: make defcustom and modify the injected command correspondingly
  2154. "String indicating the beginning of a block in watch buffer."
  2155. ;; :group 'ess-debug
  2156. ;; :type 'string
  2157. )
  2158. (defvar ess-watch-start-expression "@---:"
  2159. "String indicating the beginning of an R expression in watch buffer."
  2160. ;; :group 'ess-debug
  2161. ;; :type 'string
  2162. )
  2163. (defun ess-watch-block-limits-at-point ()
  2164. "Return start and end positions of the watch block."
  2165. (interactive)
  2166. (save-excursion
  2167. (let ((curr (point))
  2168. start-pos end-pos)
  2169. (end-of-line)
  2170. (setq start-pos
  2171. (if (re-search-backward ess-watch-start-block nil t )
  2172. (point)
  2173. (point-min)))
  2174. (goto-char curr)
  2175. (beginning-of-line)
  2176. (setq end-pos
  2177. (if (re-search-forward ess-watch-start-block nil t)
  2178. (match-beginning 0)
  2179. (point-max)))
  2180. (list start-pos end-pos))))
  2181. (defun ess-watch-block-at-point ()
  2182. "Return the current block's order count, 0 if no block was found."
  2183. (save-excursion
  2184. (let ((cur-point (point))
  2185. (count 0))
  2186. (goto-char (point-min))
  2187. (while (re-search-forward ess-watch-start-block cur-point t)
  2188. (setq count (1+ count)))
  2189. count)))
  2190. (defun ess-watch-set-current (nr)
  2191. "Move the overlay over the block with count NR in current watch buffer."
  2192. (goto-char (point-min))
  2193. (re-search-forward ess-watch-start-expression nil t nr)
  2194. (goto-char (match-end 0))
  2195. (apply 'move-overlay ess-watch-current-block-overlay (ess-watch-block-limits-at-point)))
  2196. (defun ess-watch--make-alist ()
  2197. "Create an alist of expressions from the current watch buffer.
  2198. Each element of assoc list is of the form (pos name expr) where
  2199. pos is an unique integer identifying watch blocks by position,
  2200. name is a string giving the name of expression block, expr is a
  2201. string giving the actual R expression."
  2202. (interactive)
  2203. (save-excursion
  2204. (let* ((reg-name (concat "^" ess-watch-start-block " *\\(\\S-*\\).*$"))
  2205. (reg-expr (concat "^" ess-watch-start-expression "\\s-*\\(.*\\)$"))
  2206. (reg-all (concat "\\(" reg-name "\\)\n\\(" reg-expr "\\)"))
  2207. (pos 0) wal name expr)
  2208. (goto-char (point-min))
  2209. (while (re-search-forward reg-all nil t)
  2210. (setq pos (+ 1 pos))
  2211. (setq name (match-string-no-properties 2))
  2212. (setq expr (match-string-no-properties 4))
  2213. (if (not (eq (string-to-number name) 0)) ;;if number of any kind set the name to ""
  2214. (setq name ""))
  2215. (setq wal
  2216. (append wal (list (list pos name expr)))))
  2217. wal)))
  2218. (defun ess-watch--parse-assoc (al)
  2219. "Return a string of the form 'assign(\".ess_watch_expressions\", list(a = parse(expr_a), b= parse(expr_b)), envir = .GlobalEnv)'
  2220. ready to be send to R process. AL is an association list as return by `ess-watch--make-alist'"
  2221. (concat ".ess_watch_assign_expressions(list("
  2222. (mapconcat (lambda (el)
  2223. (if (> (length (cadr el) ) 0)
  2224. (concat "`" (cadr el) "` = parse(text = '" (caddr el) "')")
  2225. (concat "parse(text = '" (caddr el) "')")))
  2226. al ", ")
  2227. "))\n"))
  2228. (defun ess-watch--install-.ess_watch_expressions ()
  2229. ;; used whenever watches are added/deleted/modified from the watch
  2230. ;; buffer. this is the only way to insert expressions into
  2231. ;; .ess_watch_expressions object in R. Assumes R watch being the current
  2232. ;; buffer, otherwise will most likely install empty list.
  2233. (interactive)
  2234. (process-send-string (ess-get-process ess-current-process-name)
  2235. (ess-watch--parse-assoc (ess-watch--make-alist)))
  2236. ;;TODO: delete the prompt at the end of proc buffer TODO: defun ess-send-string!!
  2237. (sleep-for 0.05) ;; need here, if ess-command is used immediately after, for some weird reason the process buffer will not be changed
  2238. )
  2239. (defun ess-watch-quit ()
  2240. "Quit (kill) the watch buffer.
  2241. If watch buffer exists, it is displayed during the debug
  2242. process. The only way to avoid the display, is to kill the
  2243. buffer."
  2244. (interactive)
  2245. (kill-buffer) ;; dedicated, window is deleted unless not the only one
  2246. )
  2247. ;;;_ + MOTION
  2248. (defun ess-watch-next-block (&optional n)
  2249. "Move the overlay over the next block.
  2250. Optional N if supplied gives the number of steps forward `backward-char'."
  2251. (interactive "P")
  2252. (setq n (prefix-numeric-value n))
  2253. (goto-char (overlay-end ess-watch-current-block-overlay))
  2254. (unless (re-search-forward ess-watch-start-expression nil t n)
  2255. (goto-char (point-min)) ;;circular but always moves to start!
  2256. (re-search-forward ess-watch-start-expression nil t 1))
  2257. (apply 'move-overlay ess-watch-current-block-overlay (ess-watch-block-limits-at-point)))
  2258. (defun ess-watch-previous-block (&optional n)
  2259. "Move the overlay over the previous block.
  2260. Optional N if supplied gives the number of backward steps."
  2261. (interactive "P")
  2262. (setq n (prefix-numeric-value n))
  2263. (goto-char (overlay-start ess-watch-current-block-overlay))
  2264. (unless (re-search-backward ess-watch-start-expression nil t n)
  2265. (goto-char (point-max)) ;;circular but always moves to last!
  2266. (re-search-backward ess-watch-start-expression nil t 1))
  2267. (goto-char (match-end 0))
  2268. (apply 'move-overlay ess-watch-current-block-overlay (ess-watch-block-limits-at-point)))
  2269. ;;;_ + BLOCK MANIPULATION and EDITING
  2270. (defun ess-watch-rename ()
  2271. "Rename the currently selected watch block."
  2272. (interactive)
  2273. (end-of-line)
  2274. (unless (re-search-backward ess-watch-start-block nil t)
  2275. (error "Can not find a watch block"))
  2276. (let ((reg-name (concat ess-watch-start-block " *\\(\\S-*\\).*$"))
  2277. name start end)
  2278. ;; (reg-expr (concat "^" ess-watch-start-expression "\\s-*\\(.*\\)$"))
  2279. ;; (reg-all (concat "\\(" reg-name "\\)\n\\(" reg-expr "\\)"))
  2280. ;; (pos 0) wal name expr)
  2281. (unless (re-search-forward reg-name (point-at-eol) t)
  2282. (error "Can not find the name substring in the current watch block "))
  2283. (setq name (match-string-no-properties 1))
  2284. (setq start (match-beginning 1))
  2285. (setq end (match-end 1))
  2286. (goto-char start)
  2287. ;; TODO: highlight the name in R-watch here
  2288. (setq name (read-string (concat "New name (" name "): ") nil nil name) )
  2289. (setq buffer-read-only nil)
  2290. (delete-region start end)
  2291. (insert name)
  2292. (setq buffer-read-only t)
  2293. (ess-watch--install-.ess_watch_expressions)
  2294. (ess-watch-refresh-buffer-visibly (current-buffer))))
  2295. (defun ess-watch-edit-expression ()
  2296. "Edit in the minibuffer the R expression from the current watch block."
  2297. (interactive)
  2298. (end-of-line)
  2299. (unless (re-search-backward ess-watch-start-block nil 1)
  2300. (error "Can not find a watch block"))
  2301. (let ((reg-expr (concat ess-watch-start-expression " *\\(.*\\)$"))
  2302. expr start end)
  2303. (unless (re-search-forward reg-expr nil t)
  2304. (error "Can not find an expression string in the watch block"))
  2305. (setq expr (match-string-no-properties 1))
  2306. (setq start (match-beginning 1))
  2307. (setq end (match-end 1))
  2308. (goto-char start)
  2309. ;; TODO: highlight the name in R-watch here
  2310. (setq expr (read-string "New expression: " expr nil expr) )
  2311. (setq buffer-read-only nil)
  2312. (delete-region start end)
  2313. (insert expr)
  2314. (setq buffer-read-only t)
  2315. (ess-watch--install-.ess_watch_expressions)
  2316. (ess-watch-refresh-buffer-visibly (current-buffer))))
  2317. (defun ess-watch-add ()
  2318. "Ask for new R expression and name and append it to the end of the list of watch expressions."
  2319. (interactive)
  2320. (let (nr expr name)
  2321. (goto-char (point-max))
  2322. (setq nr (number-to-string (1+ (ess-watch-block-at-point))))
  2323. (setq name nr)
  2324. ;; (setq name (read-string (concat "Name (" nr "):") nil nil nr )) ;;this one is quite annoying and not really needed than for logging
  2325. (setq expr (read-string "New expression: " nil nil "\"Empty watch!\""))
  2326. (setq buffer-read-only nil)
  2327. (insert (concat "\n" ess-watch-start-block " " name " -@\n" ess-watch-start-expression " " expr "\n"))
  2328. (setq buffer-read-only t)
  2329. (ess-watch--install-.ess_watch_expressions)))
  2330. (defun ess-watch-insert ()
  2331. "Ask for new R expression and name and insert it in front of current watch block."
  2332. (interactive)
  2333. (let (nr expr name)
  2334. (setq nr (number-to-string (ess-watch-block-at-point)))
  2335. (setq name nr)
  2336. ;; (setq name (read-string (concat "Name (" nr "):") nil nil nr ))
  2337. (setq expr (read-string "New expression: " nil nil "\"Empty watch!\""))
  2338. (re-search-backward ess-watch-start-block nil 1) ;;point-min if not found
  2339. (setq buffer-read-only nil)
  2340. (insert (concat "\n" ess-watch-start-block " " name " -@\n" ess-watch-start-expression " " expr "\n"))
  2341. (setq buffer-read-only t)
  2342. (ess-watch--install-.ess_watch_expressions)))
  2343. (defun ess-watch-move-up ()
  2344. "Move the current block up."
  2345. (interactive)
  2346. (let ((nr (ess-watch-block-at-point))
  2347. wbl)
  2348. (when (> nr 1)
  2349. (setq buffer-read-only nil)
  2350. (setq wbl (apply 'delete-and-extract-region (ess-watch-block-limits-at-point)))
  2351. (re-search-backward ess-watch-start-block nil t 1) ;; current block was deleted, point is at the end of previous block
  2352. (insert wbl)
  2353. (ess-watch--install-.ess_watch_expressions)
  2354. (setq buffer-read-only t))))
  2355. (defun ess-watch-move-down ()
  2356. "Move the current block down."
  2357. (interactive)
  2358. (let ((nr (ess-watch-block-at-point))
  2359. (nr-all (save-excursion (goto-char (point-max))
  2360. (ess-watch-block-at-point)))
  2361. wbl)
  2362. (when (< nr nr-all)
  2363. (setq buffer-read-only nil)
  2364. (setq wbl (apply 'delete-and-extract-region (ess-watch-block-limits-at-point)))
  2365. (end-of-line)
  2366. (when (re-search-forward ess-watch-start-block nil t 1) ;; current block was deleted, point is at the end of previous block or point-max
  2367. (goto-char (match-beginning 0)))
  2368. (insert wbl)
  2369. (ess-watch--install-.ess_watch_expressions)
  2370. (setq buffer-read-only t))))
  2371. (defun ess-watch-kill ()
  2372. "Kill the current block."
  2373. (interactive)
  2374. (setq buffer-read-only nil)
  2375. (apply 'delete-region (ess-watch-block-limits-at-point))
  2376. (ess-watch--install-.ess_watch_expressions))
  2377. ;;;_ + Debug/Undebug at point
  2378. (defun ess--dbg-get-signatures (method)
  2379. "Get signatures for the method METHOD."
  2380. (let ((tbuffer (get-buffer-create " *ess-command-output*")); initial space: disable-undo
  2381. signatures)
  2382. (save-excursion
  2383. (ess-if-verbose-write (format "ess-get-signatures*(%s).. " method))
  2384. (ess-command (concat "showMethods(\"" method "\")\n") tbuffer)
  2385. (message "%s" ess-local-process-name)
  2386. (message "%s" ess-current-process-name)
  2387. (ess-if-verbose-write " [ok] ..\n")
  2388. (set-buffer tbuffer)
  2389. (goto-char (point-min))
  2390. (if (not (re-search-forward "Function:" nil t))
  2391. (progn (ess-if-verbose-write "not seeing \"Function:\".. \n")
  2392. (error (buffer-string))
  2393. ;; (error "Cannot trace method '%s' (Is it a primitive method which you have already traced?)" method)
  2394. )
  2395. ;; (setq curr-point (point))
  2396. ;; (while (re-search-forward ", " nil t) ;replace all ", " with ":" for better readability in completion buffers??
  2397. ;; (replace-match ":"))
  2398. ;; (goto-char curr-point)
  2399. (while (re-search-forward "^.+$" nil t)
  2400. (setq signatures (cons (match-string-no-properties 0) signatures))))
  2401. ; (kill-buffer tbuffer)
  2402. )
  2403. signatures))
  2404. (defun ess-debug-flag-for-debugging ()
  2405. "Set the debugging flag on a function.
  2406. Ask the user for a function and if it turns to be generic, ask
  2407. for signature and trace it with browser tracer."
  2408. (interactive)
  2409. (ess-force-buffer-current "Process to use: ")
  2410. (let* ((tbuffer (get-buffer-create " *ess-command-output*")) ;; output buffer name is hard-coded in ess-inf.el
  2411. (pkg (ess-r-package-name))
  2412. (all-functions (ess-get-words-from-vector
  2413. (if pkg
  2414. (format ".ess_all_functions(c('%s'))\n" pkg)
  2415. ".ess_all_functions()\n")))
  2416. (obj-at-point (ess-helpobjs-at-point--read-obj))
  2417. (default (and
  2418. obj-at-point
  2419. (let* ((reg (regexp-quote obj-at-point))
  2420. (matches (cl-loop for el in all-functions
  2421. if (string-match reg el) collect el)))
  2422. (car (sort matches (lambda (a b) (< (length a) (length b))))))))
  2423. (ufunc (ess-completing-read "Debug" all-functions
  2424. nil nil nil nil (or default obj-at-point)))
  2425. signature)
  2426. ;; FIXME: Most of the following logic should be in R
  2427. (if (ess-boolean-command (format "as.character(isGeneric('%s'))\n" ufunc))
  2428. ;; it's S4 generic:
  2429. (save-excursion
  2430. ;; ask for exact signature
  2431. (setq signature
  2432. (ess-completing-read (concat "Method for generic '" ufunc "'")
  2433. (ess--dbg-get-signatures ufunc) ;signal an error if not found
  2434. nil t nil nil "*default*"))
  2435. (if (equal signature "*default*")
  2436. ;;debug, the default ufunc
  2437. (ess-command (format "trace('%s', tracer = browser)\n" ufunc) tbuffer)
  2438. (ess-command (format "trace('%s', tracer = browser, signature = c('%s'))\n" ufunc signature) tbuffer))
  2439. (with-current-buffer tbuffer
  2440. ;; give appropriate message or error
  2441. (message "%s" (buffer-substring-no-properties (point-min) (point-max)))))
  2442. ;;else, not an S4 generic
  2443. (when (ess-boolean-command (format "as.character(.knownS3Generics['%s'])\n" ufunc))
  2444. ;; it's S3 generic:
  2445. (setq all-functions
  2446. (ess-get-words-from-vector
  2447. (format "local({gens<-methods('%s');as.character(gens[attr(gens, 'info')$visible])})\n" ufunc)))
  2448. (setq all-functions
  2449. ;; cannot debug non-visible methods
  2450. (delq nil (mapcar (lambda (el)
  2451. (if (not (char-equal ?* (aref el (1- (length el))))) el))
  2452. all-functions)))
  2453. (setq ufunc (ess-completing-read (format "Method for S3 generic '%s'" ufunc)
  2454. (cons ufunc all-functions) nil t)))
  2455. (ess-command (format ".ess_dbg_flag_for_debuging('%s')\n" ufunc)))))
  2456. (defun ess-debug-unflag-for-debugging ()
  2457. "Prompt for the debugged/traced function or method and undebug/untrace it."
  2458. (interactive)
  2459. (let ((tbuffer (get-buffer-create " *ess-command-output*")); initial space: disable-undo\
  2460. (debugged (ess-get-words-from-vector
  2461. (if nil ;; FIXME: was checking `ess-developer-packages`
  2462. (format ".ess_dbg_getTracedAndDebugged(c('%s'))\n"
  2463. (mapconcat 'identity ess-developer-packages "', '"))
  2464. ".ess_dbg_getTracedAndDebugged()\n")))
  2465. out-message fun def-val)
  2466. ;; (prin1 debugged)
  2467. (if (eq (length debugged) 0)
  2468. (setq out-message "No debugged or traced functions/methods found")
  2469. (setq def-val (if (eq (length debugged) 1)
  2470. (car debugged)
  2471. "*ALL*"))
  2472. (setq fun (ess-completing-read "Undebug" debugged nil t nil nil def-val))
  2473. (if (equal fun "*ALL*" )
  2474. (ess-command (concat ".ess_dbg_UndebugALL(c(\"" (mapconcat 'identity debugged "\", \"") "\"))\n") tbuffer)
  2475. (ess-command (format ".ess_dbg_UntraceOrUndebug(\"%s\")\n" fun) tbuffer))
  2476. (with-current-buffer tbuffer
  2477. (if (= (point-max) 1) ;; not reliable TODO:
  2478. (setq out-message (format "Undebugged '%s' " fun))
  2479. (setq out-message (buffer-substring-no-properties (point-min) (point-max))) ;; untrace info or warning, or error occurred
  2480. )))
  2481. (message "%s" out-message)))
  2482. ;;;_ * Kludges and Fixes
  2483. ;;; delete-char and delete-backward-car do not delete whole intangible text
  2484. (defun ess--tracebug-delete-char (n &rest _)
  2485. "When deleting an intangible char, delete the whole intangible region.
  2486. Only do this when N is 1"
  2487. (when (and (ess-derived-mode-p)
  2488. (= n 1)
  2489. (get-text-property (point) 'cursor-intangible))
  2490. (kill-region (point) (or (next-single-property-change (point) 'cursor-intangible)
  2491. (point-max)))
  2492. (indent-according-to-mode)))
  2493. (advice-add 'delete-char :before-until #'ess--tracebug-delete-char)
  2494. (defun ess--tracebug-delete-backward-char (n &rest _)
  2495. "When deleting an intangible char, delete the whole intangible region.
  2496. Only do this when called interactively and N is 1"
  2497. (when (and (ess-derived-mode-p)
  2498. (= n 1)
  2499. (> (point) (point-min))
  2500. (get-text-property (1- (point)) 'cursor-intangible))
  2501. (kill-region (or (previous-single-property-change (point) 'cursor-intangible)
  2502. (point-min))
  2503. (point))))
  2504. (advice-add 'delete-backward-char :before-until #'ess--tracebug-delete-backward-char)
  2505. (provide 'ess-tracebug)
  2506. ;;; ess-tracebug.el ends here