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.
745 lines
27 KiB
745 lines
27 KiB
9 years ago
|
;;; 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
|