You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

744 lines
27 KiB

;;; haskell-debug.el --- Debugging mode via GHCi -*- lexical-binding: t -*-
;; Copyright (c) 2014 Chris Done. All rights reserved.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Code:
(require 'cl-lib)
(require 'haskell-session)
(require 'haskell-process)
(require 'haskell-interactive-mode)
(require 'haskell-font-lock)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Configuration
;;;###autoload
(defgroup haskell-debug nil
"Settings for debugging support."
:link '(custom-manual "(haskell-mode)haskell-debug")
:group 'haskell)
;;;###autoload
(defface haskell-debug-warning-face
'((t :inherit 'compilation-warning))
"Face for warnings."
:group 'haskell-debug)
;;;###autoload
(defface haskell-debug-trace-number-face
'((t :weight bold :background "#f5f5f5"))
"Face for numbers in backtrace."
:group 'haskell-debug)
;;;###autoload
(defface haskell-debug-newline-face
'((t :weight bold :background "#f0f0f0"))
"Face for newlines in trace steps."
:group 'haskell-debug)
;;;###autoload
(defface haskell-debug-keybinding-face
'((t :inherit 'font-lock-type-face :weight bold))
"Face for keybindings."
:group 'haskell-debug)
;;;###autoload
(defface haskell-debug-heading-face
'((t :inherit 'font-lock-keyword-face))
"Face for headings."
:group 'haskell-debug)
;;;###autoload
(defface haskell-debug-muted-face
'((t :foreground "#999"))
"Face for muteds."
:group 'haskell-debug)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mode
(define-derived-mode haskell-debug-mode
text-mode "Debug"
"Major mode for debugging Haskell via GHCi.")
(define-key haskell-debug-mode-map (kbd "g") 'haskell-debug/refresh)
(define-key haskell-debug-mode-map (kbd "s") 'haskell-debug/step)
(define-key haskell-debug-mode-map (kbd "t") 'haskell-debug/trace)
(define-key haskell-debug-mode-map (kbd "d") 'haskell-debug/delete)
(define-key haskell-debug-mode-map (kbd "b") 'haskell-debug/break-on-function)
(define-key haskell-debug-mode-map (kbd "a") 'haskell-debug/abandon)
(define-key haskell-debug-mode-map (kbd "c") 'haskell-debug/continue)
(define-key haskell-debug-mode-map (kbd "p") 'haskell-debug/previous)
(define-key haskell-debug-mode-map (kbd "n") 'haskell-debug/next)
(define-key haskell-debug-mode-map (kbd "RET") 'haskell-debug/select)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Globals
(defvar haskell-debug-history-cache nil
"Cache of the tracing history.")
(defvar haskell-debug-bindings-cache nil
"Cache of the current step's bindings.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Macros
(defmacro haskell-debug-with-breakpoints (&rest body)
"Breakpoints need to exist to start stepping."
`(if (haskell-debug-get-breakpoints)
,@body
(error "No breakpoints to step into!")))
(defmacro haskell-debug-with-modules (&rest body)
"Modules need to exist to do debugging stuff."
`(if (haskell-debug-get-modules)
,@body
(error "No modules loaded!")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interactive functions
(defun haskell-debug/select ()
"Select whatever is at point."
(interactive)
(cond
((get-text-property (point) 'break)
(let ((break (get-text-property (point) 'break)))
(haskell-debug-highlight (plist-get break :path)
(plist-get break :span))))
((get-text-property (point) 'module)
(let ((break (get-text-property (point) 'module)))
(haskell-debug-highlight (plist-get break :path))))))
(defun haskell-debug/abandon ()
"Abandon the current computation."
(interactive)
(haskell-debug-with-breakpoints
(haskell-process-queue-sync-request (haskell-debug-process) ":abandon")
(message "Computation abandoned.")
(setq haskell-debug-history-cache nil)
(setq haskell-debug-bindings-cache nil)
(haskell-debug/refresh)))
(defun haskell-debug/continue ()
"Continue the current computation."
(interactive)
(haskell-debug-with-breakpoints
(haskell-process-queue-sync-request (haskell-debug-process) ":continue")
(message "Computation continued.")
(setq haskell-debug-history-cache nil)
(setq haskell-debug-bindings-cache nil)
(haskell-debug/refresh)))
(defun haskell-debug/break-on-function ()
"Break on function IDENT."
(interactive)
(haskell-debug-with-modules
(let ((ident (read-from-minibuffer "Function: "
(haskell-ident-at-point))))
(haskell-process-queue-sync-request
(haskell-debug-process)
(concat ":break "
ident))
(message "Breaking on function: %s" ident)
(haskell-debug/refresh))))
(defun haskell-debug/start-step (expr)
"Start stepping EXPR."
(interactive (list (read-from-minibuffer "Expression to step through: ")))
(haskell-debug/step expr))
(defun haskell-debug/breakpoint-numbers ()
"List breakpoint numbers."
(interactive)
(let ((breakpoints (mapcar (lambda (breakpoint)
(number-to-string (plist-get breakpoint :number)))
(haskell-debug-get-breakpoints))))
(if (null breakpoints)
(message "No breakpoints.")
(message "Breakpoint(s): %s"
(mapconcat #'identity
breakpoints
", ")))))
(defun haskell-debug/next ()
"Go to next step to inspect bindings."
(interactive)
(haskell-debug-with-breakpoints
(haskell-debug-navigate "forward")))
(defun haskell-debug/previous ()
"Go to previous step to inspect the bindings."
(interactive)
(haskell-debug-with-breakpoints
(haskell-debug-navigate "back")))
(defun haskell-debug/refresh ()
"Refresh the debugger buffer."
(interactive)
(with-current-buffer (haskell-debug-buffer-name (haskell-debug-session))
(cd (haskell-session-current-dir (haskell-debug-session)))
(let ((inhibit-read-only t)
(p (point)))
(erase-buffer)
(insert (propertize (concat "Debugging "
(haskell-session-name (haskell-debug-session))
"\n\n")
'face `((:weight bold))))
(let ((modules (haskell-debug-get-modules))
(breakpoints (haskell-debug-get-breakpoints))
(context (haskell-debug-get-context))
(history (haskell-debug-get-history)))
(unless modules
(insert (propertize "You have to load a module to start debugging."
'face
'haskell-debug-warning-face)
"\n\n"))
(haskell-debug-insert-bindings modules breakpoints context)
(when modules
(haskell-debug-insert-current-context context history)
(haskell-debug-insert-breakpoints breakpoints))
(haskell-debug-insert-modules modules))
(insert "\n")
(goto-char (min (point-max) p)))))
(defun haskell-debug/delete ()
"Delete whatever's at the point."
(interactive)
(cond
((get-text-property (point) 'break)
(let ((break (get-text-property (point) 'break)))
(when (y-or-n-p (format "Delete breakpoint #%d?"
(plist-get break :number)))
(haskell-process-queue-sync-request
(haskell-debug-process)
(format ":delete %d"
(plist-get break :number)))
(haskell-debug/refresh))))))
(defun haskell-debug/trace ()
"Trace the expression."
(interactive)
(haskell-debug-with-modules
(haskell-debug-with-breakpoints
(let ((expr (read-from-minibuffer "Expression to trace: "
(haskell-ident-at-point))))
(haskell-process-queue-sync-request
(haskell-debug-process)
(concat ":trace " expr))
(message "Tracing expression: %s" expr)
(haskell-debug/refresh)))))
(defun haskell-debug/step (&optional expr)
"Step into the next function."
(interactive)
(haskell-debug-with-breakpoints
(let* ((breakpoints (haskell-debug-get-breakpoints))
(context (haskell-debug-get-context))
(string
(haskell-process-queue-sync-request
(haskell-debug-process)
(if expr
(concat ":step " expr)
":step"))))
(cond
((string= string "not stopped at a breakpoint\n")
(if haskell-debug-bindings-cache
(progn (setq haskell-debug-bindings-cache nil)
(haskell-debug/refresh))
(call-interactively 'haskell-debug/start-step)))
(t (let ((maybe-stopped-at (haskell-debug-parse-stopped-at string)))
(cond
(maybe-stopped-at
(setq haskell-debug-bindings-cache
maybe-stopped-at)
(message "Computation paused.")
(haskell-debug/refresh))
(t
(if context
(message "Computation finished.")
(when (y-or-n-p "Computation completed without breaking. Reload the module and retry?")
(message "Reloading and resetting breakpoints...")
(haskell-interactive-mode-reset-error (haskell-debug-session))
(cl-loop for break in breakpoints
do (haskell-process-queue-sync-request
(haskell-debug-process)
(concat ":load " (plist-get break :path))))
(cl-loop for break in breakpoints
do (haskell-debug-break break))
(haskell-debug/step expr)))))))))
(haskell-debug/refresh)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal functions
(defun haskell-debug-session ()
"Get the Haskell session."
(or (haskell-session-maybe)
(error "No Haskell session associated with this debug
buffer. Please just close the buffer and start again.")))
(defun haskell-debug-process ()
"Get the Haskell session."
(or (haskell-session-process (haskell-session-maybe))
(error "No Haskell session associated with this debug
buffer. Please just close the buffer and start again.")))
(defun haskell-debug-buffer-name (session)
"The debug buffer name for the current session."
(format "*debug:%s*"
(haskell-session-name session)))
(defun haskell-debug-get-breakpoints ()
"Get the list of breakpoints currently set."
(let ((string (haskell-process-queue-sync-request
(haskell-debug-process)
":show breaks")))
(if (string= string "No active breakpoints.\n")
(list)
(mapcar #'haskell-debug-parse-break-point
(haskell-debug-split-string string)))))
(defun haskell-debug-get-modules ()
"Get the list of modules currently set."
(let ((string (haskell-process-queue-sync-request
(haskell-debug-process)
":show modules")))
(if (string= string "")
(list)
(mapcar #'haskell-debug-parse-module
(haskell-debug-split-string string)))))
(defun haskell-debug-get-context ()
"Get the current context."
(let ((string (haskell-process-queue-sync-request
(haskell-debug-process)
":show context")))
(if (string= string "")
nil
(haskell-debug-parse-context string))))
(defun haskell-debug-get-history ()
"Get the step history."
(let ((string (haskell-process-queue-sync-request
(haskell-debug-process)
":history")))
(if (or (string= string "")
(string= string "Not stopped at a breakpoint\n"))
nil
(if (string= string "Empty history. Perhaps you forgot to use :trace?\n")
nil
(let ((entries (mapcar #'haskell-debug-parse-history-entry
(cl-remove-if (lambda (line) (or (string= "<end of history>" line)
(string= "..." line)))
(haskell-debug-split-string string)))))
(setq haskell-debug-history-cache
entries)
entries)))))
(defun haskell-debug-insert-bindings (modules breakpoints context)
"Insert a list of bindings."
(if breakpoints
(progn (haskell-debug-insert-binding "t" "trace an expression")
(haskell-debug-insert-binding "s" "step into an expression")
(haskell-debug-insert-binding "b" "breakpoint" t))
(progn
(when modules
(haskell-debug-insert-binding "b" "breakpoint"))
(when breakpoints
(haskell-debug-insert-binding "s" "step into an expression" t))))
(when breakpoints
(haskell-debug-insert-binding "d" "delete breakpoint"))
(when context
(haskell-debug-insert-binding "a" "abandon context")
(haskell-debug-insert-binding "c" "continue" t))
(when context
(haskell-debug-insert-binding "p" "previous step")
(haskell-debug-insert-binding "n" "next step" t))
(haskell-debug-insert-binding "g" "refresh" t)
(insert "\n"))
(defun haskell-debug-insert-current-context (context history)
"Insert the current context."
(haskell-debug-insert-header "Context")
(if context
(haskell-debug-insert-context context history)
(haskell-debug-insert-debug-finished))
(insert "\n"))
(defun haskell-debug-insert-breakpoints (breakpoints)
"insert the list of breakpoints."
(haskell-debug-insert-header "Breakpoints")
(if (null breakpoints)
(haskell-debug-insert-muted "No active breakpoints.")
(cl-loop for break in breakpoints
do (insert (propertize (format "%d"
(plist-get break :number))
'face `((:weight bold))
'break break)
(haskell-debug-muted " - ")
(propertize (plist-get break :module)
'break break
'break break)
(haskell-debug-muted
(format " (%d:%d)"
(plist-get (plist-get break :span) :start-line)
(plist-get (plist-get break :span) :start-col)))
"\n")))
(insert "\n"))
(defun haskell-debug-insert-modules (modules)
"Insert the list of modules."
(haskell-debug-insert-header "Modules")
(if (null modules)
(haskell-debug-insert-muted "No loaded modules.")
(progn (cl-loop for module in modules
do (insert (propertize (plist-get module :module)
'module module
'face `((:weight bold)))
(haskell-debug-muted " - ")
(propertize (file-name-nondirectory (plist-get module :path))
'module module))
do (insert "\n")))))
(defun haskell-debug-split-string (string)
"Split GHCi's line-based output, stripping the trailing newline."
(split-string string "\n" t))
(defun haskell-debug-parse-context (string)
"Parse the context."
(cond
((string-match "^--> \\(.+\\)\n \\(.+\\)" string)
(let ((name (match-string 1 string))
(stopped (haskell-debug-parse-stopped-at (match-string 2 string))))
(list :name name
:path (plist-get stopped :path)
:span (plist-get stopped :span))))))
(defun haskell-debug-insert-binding (binding desc &optional end)
"Insert a helpful keybinding."
(insert (propertize binding 'face 'haskell-debug-keybinding-face)
(haskell-debug-muted " - ")
desc
(if end
"\n"
(haskell-debug-muted ", "))))
(defun haskell-debug-insert-header (title)
"Insert a header title."
(insert (propertize title
'face 'haskell-debug-heading-face)
"\n\n"))
(defun haskell-debug-insert-context (context history)
"Insert the context and history."
(when context
(insert (propertize (plist-get context :name) 'face `((:weight bold)))
(haskell-debug-muted " - ")
(file-name-nondirectory (plist-get context :path))
(haskell-debug-muted " (stopped)")
"\n"))
(when haskell-debug-bindings-cache
(insert "\n")
(let ((bindings haskell-debug-bindings-cache))
(insert
(haskell-debug-get-span-string
(plist-get bindings :path)
(plist-get bindings :span)))
(insert "\n\n")
(cl-loop for binding in (plist-get bindings :types)
do (insert (haskell-fontify-as-mode binding 'haskell-mode)
"\n"))))
(let ((history (or history
(list (haskell-debug-make-fake-history context)))))
(when history
(insert "\n")
(haskell-debug-insert-history history))))
(defun haskell-debug-insert-debug-finished ()
"Insert message that no debugging is happening, but if there is
some old history, then display that."
(if haskell-debug-history-cache
(progn (haskell-debug-insert-muted "Finished debugging.")
(insert "\n")
(haskell-debug-insert-history haskell-debug-history-cache))
(haskell-debug-insert-muted "Not debugging right now.")))
(defun haskell-debug-insert-muted (text)
"Insert some muted text."
(insert (haskell-debug-muted text)
"\n"))
(defun haskell-debug-muted (text)
"Make some muted text."
(propertize text 'face 'haskell-debug-muted-face))
(defun haskell-debug-parse-logged (string)
"Parse the logged breakpoint."
(cond
((string= "no more logged breakpoints\n" string)
nil)
((string= "already at the beginning of the history\n" string)
nil)
(t
(with-temp-buffer
(insert string)
(goto-char (point-min))
(list :path (progn (search-forward " at ")
(buffer-substring-no-properties
(point)
(1- (search-forward ":"))))
:span (haskell-debug-parse-span
(buffer-substring-no-properties
(point)
(line-end-position)))
:types (progn (forward-line)
(haskell-debug-split-string
(buffer-substring-no-properties
(point)
(point-max)))))))))
(defun haskell-debug-parse-stopped-at (string)
"Parse the location stopped at from the given string.
For example:
Stopped at /home/foo/project/src/x.hs:6:25-36
"
(let ((index (string-match "Stopped at \\([^:]+\\):\\(.+\\)\n?"
string)))
(when index
(list :path (match-string 1 string)
:span (haskell-debug-parse-span (match-string 2 string))
:types (cdr (haskell-debug-split-string (substring string index)))))))
(defun haskell-debug-get-span-string (path span)
"Get the string from the PATH and the SPAN."
(save-window-excursion
(find-file path)
(buffer-substring
(save-excursion
(goto-char (point-min))
(forward-line (1- (plist-get span :start-line)))
(forward-char (1- (plist-get span :start-col)))
(point))
(save-excursion
(goto-char (point-min))
(forward-line (1- (plist-get span :end-line)))
(forward-char (plist-get span :end-col))
(point)))))
(defun haskell-debug-make-fake-history (context)
"Make a fake history item."
(list :index -1
:path (plist-get context :path)
:span (plist-get context :span)))
(defun haskell-debug-insert-history (history)
"Insert tracing HISTORY."
(let ((i (length history)))
(cl-loop for span in history
do (let ((string (haskell-debug-get-span-string
(plist-get span :path)
(plist-get span :span))))
(insert (propertize (format "%4d" i)
'face 'haskell-debug-trace-number-face)
" "
(haskell-debug-preview-span
(plist-get span :span)
string
t)
"\n")
(setq i (1- i))))))
(defun haskell-debug-parse-span (string)
"Parse a source span from a string.
Examples:
(5,1)-(6,37)
6:25-36
5:20
People like to make other people's lives interesting by making
variances in source span notation."
(cond
((string-match "\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)"
string)
(list :start-line (string-to-number (match-string 1 string))
:start-col (string-to-number (match-string 2 string))
:end-line (string-to-number (match-string 1 string))
:end-col (string-to-number (match-string 3 string))))
((string-match "\\([0-9]+\\):\\([0-9]+\\)"
string)
(list :start-line (string-to-number (match-string 1 string))
:start-col (string-to-number (match-string 2 string))
:end-line (string-to-number (match-string 1 string))
:end-col (string-to-number (match-string 2 string))))
((string-match "(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))"
string)
(list :start-line (string-to-number (match-string 1 string))
:start-col (string-to-number (match-string 2 string))
:end-line (string-to-number (match-string 3 string))
:end-col (string-to-number (match-string 4 string))))
(t (error "Unable to parse source span from string: %s"
string))))
(defun haskell-debug-preview-span (span string &optional collapsed)
"Make a one-line preview of the given expression."
(with-temp-buffer
(haskell-mode)
(insert string)
(when (/= 0 (plist-get span :start-col))
(indent-rigidly (point-min)
(point-max)
1))
(if (fboundp 'font-lock-ensure)
(font-lock-ensure)
(with-no-warnings (font-lock-fontify-buffer)))
(when (/= 0 (plist-get span :start-col))
(indent-rigidly (point-min)
(point-max)
-1))
(goto-char (point-min))
(if collapsed
(replace-regexp-in-string
"\n[ ]*"
(propertize " " 'face 'haskell-debug-newline-face)
(buffer-substring (point-min)
(point-max)))
(buffer-string))))
(defun haskell-debug-start (session)
"Start the debug mode."
(setq buffer-read-only t)
(haskell-session-assign session)
(haskell-debug/refresh))
(defun haskell-debug ()
"Start the debugger for the current Haskell (GHCi) session."
(interactive)
(let ((session (haskell-debug-session)))
(switch-to-buffer-other-window (haskell-debug-buffer-name session))
(unless (eq major-mode 'haskell-debug-mode)
(haskell-debug-mode)
(haskell-debug-start session))))
(defun haskell-debug-break (break)
"Set BREAK breakpoint in module at line/col."
(haskell-process-queue-without-filters
(haskell-debug-process)
(format ":break %s %s %d"
(plist-get break :module)
(plist-get (plist-get break :span) :start-line)
(plist-get (plist-get break :span) :start-col))))
(defun haskell-debug-navigate (direction)
"Navigate in DIRECTION \"back\" or \"forward\"."
(let ((string (haskell-process-queue-sync-request
(haskell-debug-process)
(concat ":" direction))))
(let ((bindings (haskell-debug-parse-logged string)))
(setq haskell-debug-bindings-cache
bindings)
(when (not bindings)
(message "No more %s results!" direction)))
(haskell-debug/refresh)))
(defun haskell-debug-session-debugging-p (session)
"Does the session have a debugging buffer open?"
(not (not (get-buffer (haskell-debug-buffer-name session)))))
(defun haskell-debug-highlight (path &optional span)
"Highlight the file at span."
(let ((p (make-overlay
(line-beginning-position)
(line-end-position))))
(overlay-put p 'face `((:background "#eee")))
(with-current-buffer
(if span
(save-window-excursion
(find-file path)
(current-buffer))
(find-file path)
(current-buffer))
(let ((o (when span
(make-overlay
(save-excursion
(goto-char (point-min))
(forward-line (1- (plist-get span :start-line)))
(forward-char (1- (plist-get span :start-col)))
(point))
(save-excursion
(goto-char (point-min))
(forward-line (1- (plist-get span :end-line)))
(forward-char (plist-get span :end-col))
(point))))))
(when o
(overlay-put o 'face `((:background "#eee"))))
(sit-for 0.5)
(when o
(delete-overlay o))
(delete-overlay p)))))
(defun haskell-debug-parse-history-entry (string)
"Parse a history entry."
(if (string-match "^\\([-0-9]+\\)[ ]+:[ ]+\\([A-Za-z0-9_':]+\\)[ ]+(\\([^:]+\\):\\(.+?\\))$"
string)
(list :index (string-to-number (match-string 1 string))
:name (match-string 2 string)
:path (match-string 3 string)
:span (haskell-debug-parse-span (match-string 4 string)))
(error "Unable to parse history entry: %s" string)))
(defun haskell-debug-parse-module (string)
"Parse a module and path.
For example:
X ( /home/foo/X.hs, interpreted )
"
(if (string-match "^\\([^ ]+\\)[ ]+( \\([^ ]+?\\), [a-z]+ )$"
string)
(list :module (match-string 1 string)
:path (match-string 2 string))
(error "Unable to parse module from string: %s"
string)))
(defun haskell-debug-parse-break-point (string)
"Parse a breakpoint number, module and location from a string.
For example:
[13] Main /home/foo/src/x.hs:(5,1)-(6,37)
"
(if (string-match "^\\[\\([0-9]+\\)\\] \\([^ ]+\\) \\([^:]+\\):\\(.+\\)$"
string)
(list :number (string-to-number (match-string 1 string))
:module (match-string 2 string)
:path (match-string 3 string)
:span (haskell-debug-parse-span (match-string 4 string)))
(error "Unable to parse breakpoint from string: %s"
string)))
(provide 'haskell-debug)
;;; haskell-debug.el ends here