Mercurial > hg > Members > kokubo > emacs

comparison .emacs.d/haskell-mode/haskell-debug.el @ 0:2764b4f45f9f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
1st commit
author Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
date Mon, 21 Apr 2014 04:30:59 +0900
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:2764b4f45f9f
1 ;;; haskell-debug.el --- Debugging mode via GHCi
2
3 ;; Copyright (c) 2014 Chris Done. All rights reserved.
4
5 ;; This file is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation; either version 3, or (at your option)
8 ;; any later version.
9
10 ;; This file is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17
18 ;;; Code:
19
20 (require 'cl)
21
22 (defmacro haskell-debug-with-breakpoints (&rest body)
23 "Breakpoints need to exist to start stepping."
24 `(if (haskell-debug-get-breakpoints)
25 ,@body
26 (error "No breakpoints to step into!")))
27
28 (defmacro haskell-debug-with-modules (&rest body)
29 "Modules need to exist to do debugging stuff."
30 `(if (haskell-debug-get-modules)
31 ,@body
32 (error "No modules loaded!")))
33
34 (define-derived-mode haskell-debug-mode
35 text-mode "Debug"
36 "Major mode for debugging Haskell via GHCi.")
37
38 (define-key haskell-debug-mode-map (kbd "g") 'haskell-debug/refresh)
39 (define-key haskell-debug-mode-map (kbd "s") 'haskell-debug/step)
40 (define-key haskell-debug-mode-map (kbd "d") 'haskell-debug/delete)
41 (define-key haskell-debug-mode-map (kbd "b") 'haskell-debug/break-on-function)
42 (define-key haskell-debug-mode-map (kbd "a") 'haskell-debug/abandon)
43 (define-key haskell-debug-mode-map (kbd "c") 'haskell-debug/continue)
44 (define-key haskell-debug-mode-map (kbd "p") 'haskell-debug/previous)
45 (define-key haskell-debug-mode-map (kbd "n") 'haskell-debug/next)
46 (define-key haskell-debug-mode-map (kbd "RET") 'haskell-debug/select)
47
48 (defvar haskell-debug-history-cache nil
49 "Cache of the tracing history.")
50
51 (defvar haskell-debug-bindings-cache nil
52 "Cache of the current step's bindings.")
53
54 (defun haskell-debug-session-debugging-p (session)
55 "Does the session have a debugging buffer open?"
56 (not (not (get-buffer (haskell-debug-buffer-name session)))))
57
58 (defun haskell-debug ()
59 "Start the debugger for the current Haskell (GHCi) session."
60 (interactive)
61 (let ((session (haskell-session)))
62 (switch-to-buffer-other-window (haskell-debug-buffer-name session))
63 (unless (eq major-mode 'haskell-debug-mode)
64 (haskell-debug-mode)
65 (haskell-debug-start session))))
66
67 (defun haskell-debug/delete ()
68 "Delete whatever's at the point."
69 (interactive)
70 (cond
71 ((get-text-property (point) 'break)
72 (let ((break (get-text-property (point) 'break)))
73 (when (y-or-n-p (format "Delete breakpoint #%d?"
74 (plist-get break :number)))
75 (haskell-process-queue-sync-request
76 (haskell-process)
77 (format ":delete %d"
78 (plist-get break :number)))
79 (haskell-debug/refresh))))))
80
81 (defun haskell-debug/step (&optional expr)
82 "Step into the next function."
83 (interactive)
84 (haskell-debug-with-breakpoints
85 (let* ((breakpoints (haskell-debug-get-breakpoints))
86 (context (haskell-debug-get-context))
87 (string
88 (haskell-process-queue-sync-request
89 (haskell-process)
90 (if expr
91 (concat ":step " expr)
92 ":step"))))
93 (cond
94 ((string= string "not stopped at a breakpoint")
95 (if haskell-debug-bindings-cache
96 (progn (setq haskell-debug-bindings-cache nil)
97 (haskell-debug/refresh))
98 (call-interactively 'haskell-debug/start-step)))
99 (t (let ((maybe-stopped-at (haskell-debug-parse-stopped-at string)))
100 (cond
101 (maybe-stopped-at
102 (set (make-local-variable 'haskell-debug-bindings-cache)
103 maybe-stopped-at)
104 (message "Computation paused.")
105 (haskell-debug/refresh))
106 (t
107 (if context
108 (message "Computation finished.")
109 (when (y-or-n-p "Computation completed without breaking. Reload the module and retry?")
110 (message "Reloading and resetting breakpoints...")
111 (haskell-interactive-mode-reset-error (haskell-session))
112 (loop for break in breakpoints
113 do (haskell-process-file-loadish
114 (concat "load " (plist-get break :path))
115 nil
116 nil))
117 (loop for break in breakpoints
118 do (haskell-debug-break break))
119 (haskell-debug/step expr)))))))))
120 (haskell-debug/refresh)))
121
122 (defun haskell-debug/start-step (expr)
123 "Start stepping EXPR."
124 (interactive (list (read-from-minibuffer "Expression to step through: ")))
125 (haskell-debug/step expr))
126
127 (defun haskell-debug/refresh ()
128 "Refresh the debugger buffer."
129 (interactive)
130 (with-current-buffer (haskell-debug-buffer-name (haskell-session))
131 (let ((inhibit-read-only t)
132 (p (point)))
133 (erase-buffer)
134 (insert (propertize (concat "Debugging "
135 (haskell-session-name (haskell-session))
136 "\n\n")
137 'face `((:weight bold))))
138 (let ((modules (haskell-debug-get-modules))
139 (breakpoints (haskell-debug-get-breakpoints))
140 (context (haskell-debug-get-context))
141 (history (haskell-debug-get-history)))
142 (unless modules
143 (insert (propertize "You have to load a module to start debugging.\n\n"
144 'face
145 `((:foreground ,sunburn-red)))))
146 (haskell-debug-insert-bindings modules breakpoints context)
147 (when modules
148 (haskell-debug-insert-current-context context history)
149 (haskell-debug-insert-breakpoints breakpoints))
150 (haskell-debug-insert-modules modules))
151 (insert "\n")
152 (goto-char (min (point-max) p)))))
153
154 (defun haskell-debug-break (break)
155 "Set BREAK breakpoint in module at line/col."
156 (haskell-process-queue-without-filters
157 (haskell-process)
158 (format ":break %s %s %d"
159 (plist-get break :module)
160 (plist-get (plist-get break :span) :start-line)
161 (plist-get (plist-get break :span) :start-col))))
162
163 (defun haskell-debug-insert-current-context (context history)
164 "Insert the current context."
165 (haskell-debug-insert-header "Context")
166 (if context
167 (haskell-debug-insert-context context history)
168 (haskell-debug-insert-debug-finished))
169 (insert "\n"))
170
171 (defun haskell-debug-insert-debug-finished ()
172 "Insert message that no debugging is happening, but if there is
173 some old history, then display that."
174 (if haskell-debug-history-cache
175 (progn (haskell-debug-insert-muted "Finished debugging.")
176 (insert "\n")
177 (haskell-debug-insert-history haskell-debug-history-cache))
178 (haskell-debug-insert-muted "Not debugging right now.")))
179
180 (defun haskell-debug-insert-context (context history)
181 "Insert the context and history."
182 (when context
183 (insert (propertize (plist-get context :name) 'face `((:weight bold)))
184 (haskell-debug-muted " - ")
185 (file-name-nondirectory (plist-get context :path))
186 (haskell-debug-muted " (stopped)")
187 "\n"))
188 (when haskell-debug-bindings-cache
189 (insert "\n")
190 (let ((bindings haskell-debug-bindings-cache))
191 (insert
192 (haskell-debug-get-span-string
193 (plist-get bindings :path)
194 (plist-get bindings :span)))
195 (insert "\n\n")
196 (loop for binding in (plist-get bindings :types)
197 do (insert (haskell-fontify-as-mode binding 'haskell-mode)
198 "\n"))))
199 (let ((history (or history
200 (list (haskell-debug-make-fake-history context)))))
201 (when history
202 (insert "\n")
203 (haskell-debug-insert-history history))))
204
205 (defun haskell-debug-insert-history (history)
206 "Insert tracing HISTORY."
207 (let ((i (length history)))
208 (loop for span in history
209 do (let ((string (haskell-debug-get-span-string
210 (plist-get span :path)
211 (plist-get span :span)))
212 (index (plist-get span :index)))
213 (insert (propertize (format "%4d" i)
214 'face `((:weight bold :background ,sunburn-bg+1)))
215 " "
216 (haskell-debug-preview-span
217 (plist-get span :span)
218 string
219 t)
220 "\n")
221 (setq i (1- i))))))
222
223 (defun haskell-debug-make-fake-history (context)
224 "Make a fake history item."
225 (list :index -1
226 :path (plist-get context :path)
227 :span (plist-get context :span)))
228
229 (defun haskell-debug-preview-span (span string &optional collapsed)
230 "Make a one-line preview of the given expression."
231 (with-temp-buffer
232 (haskell-mode)
233 (insert string)
234 (when (/= 0 (plist-get span :start-col))
235 (indent-rigidly (point-min)
236 (point-max)
237 1))
238 (font-lock-fontify-buffer)
239 (when (/= 0 (plist-get span :start-col))
240 (indent-rigidly (point-min)
241 (point-max)
242 -1))
243 (goto-char (point-min))
244 (if collapsed
245 (replace-regexp-in-string
246 "\n[ ]*"
247 (propertize " " 'face `((:background ,sunburn-bg+1)))
248 (buffer-substring (point-min)
249 (point-max)))
250 (buffer-string))))
251
252 (defun haskell-debug-get-span-string (path span)
253 "Get the string from the PATH and the SPAN."
254 (save-window-excursion
255 (find-file path)
256 (buffer-substring
257 (save-excursion
258 (goto-char (point-min))
259 (forward-line (1- (plist-get span :start-line)))
260 (forward-char (1- (plist-get span :start-col)))
261 (point))
262 (save-excursion
263 (goto-char (point-min))
264 (forward-line (1- (plist-get span :end-line)))
265 (forward-char (plist-get span :end-col))
266 (point)))))
267
268 (defun haskell-debug-insert-bindings (modules breakpoints context)
269 "Insert a list of bindings."
270 (if breakpoints
271 (progn (haskell-debug-insert-binding "s" "step into an expression")
272 (haskell-debug-insert-binding "b" "breakpoint" t))
273 (progn
274 (when modules
275 (haskell-debug-insert-binding "b" "breakpoint"))
276 (when breakpoints
277 (haskell-debug-insert-binding "s" "step into an expression" t))))
278 (when breakpoints
279 (haskell-debug-insert-binding "d" "delete breakpoint"))
280 (when context
281 (haskell-debug-insert-binding "a" "abandon context")
282 (haskell-debug-insert-binding "c" "continue" t))
283 (when context
284 (haskell-debug-insert-binding "p" "previous step")
285 (haskell-debug-insert-binding "n" "next step" t))
286 (haskell-debug-insert-binding "g" "refresh" t)
287 (insert "\n"))
288
289 (defun haskell-debug-insert-binding (binding desc &optional end)
290 "Insert a helpful keybinding."
291 (insert (propertize binding 'face `((:foreground ,sunburn-blue :weight bold)))
292 (haskell-debug-muted " - ")
293 desc
294 (if end
295 "\n"
296 (haskell-debug-muted ", "))))
297
298 (defun haskell-debug/breakpoint-numbers ()
299 "List breakpoint numbers."
300 (interactive)
301 (let ((breakpoints (mapcar (lambda (breakpoint)
302 (number-to-string (plist-get breakpoint :number)))
303 (haskell-debug-get-breakpoints))))
304 (if (null breakpoints)
305 (message "No breakpoints.")
306 (message "Breakpoint(s): %s"
307 (mapconcat #'identity
308 breakpoints
309 ", ")))))
310
311 (defun haskell-debug/abandon ()
312 "Abandon the current computation."
313 (interactive)
314 (haskell-debug-with-breakpoints
315 (haskell-process-queue-sync-request (haskell-process) ":abandon")
316 (message "Computation abandoned.")
317 (setq haskell-debug-history-cache nil)
318 (setq haskell-debug-bindings-cache nil)
319 (haskell-debug/refresh)))
320
321 (defun haskell-debug/continue ()
322 "Continue the current computation."
323 (interactive)
324 (haskell-debug-with-breakpoints
325 (haskell-process-queue-sync-request (haskell-process) ":continue")
326 (message "Computation continued.")
327 (setq haskell-debug-history-cache nil)
328 (setq haskell-debug-bindings-cache nil)
329 (haskell-debug/refresh)))
330
331 (defun haskell-debug/break-on-function ()
332 "Break on function IDENT."
333 (interactive)
334 (haskell-debug-with-modules
335 (let ((ident (read-from-minibuffer "Function: "
336 (haskell-ident-at-point))))
337 (haskell-process-queue-sync-request
338 (haskell-process)
339 (concat ":break "
340 ident))
341 (message "Breaking on function: %s" ident)
342 (haskell-debug/refresh))))
343
344 (defun haskell-debug/select ()
345 "Select whatever is at point."
346 (interactive)
347 (cond
348 ((get-text-property (point) 'break)
349 (let ((break (get-text-property (point) 'break)))
350 (haskell-debug-highlight (plist-get break :path)
351 (plist-get break :span))))
352 ((get-text-property (point) 'module)
353 (let ((break (get-text-property (point) 'module)))
354 (haskell-debug-highlight (plist-get break :path))))))
355
356 (defun haskell-debug/next ()
357 "Go to next step to inspect bindings."
358 (interactive)
359 (haskell-debug-with-breakpoints
360 (haskell-debug-navigate "forward")))
361
362 (defun haskell-debug/previous ()
363 "Go to previous step to inspect the bindings."
364 (interactive)
365 (haskell-debug-with-breakpoints
366 (haskell-debug-navigate "back")))
367
368 (defun haskell-debug-highlight (path &optional span)
369 "Highlight the file at span."
370 (let ((p (make-overlay
371 (line-beginning-position)
372 (line-end-position))))
373 (overlay-put p 'face `((:background ,sunburn-bg+1)))
374 (with-current-buffer
375 (if span
376 (save-window-excursion
377 (find-file path)
378 (current-buffer))
379 (find-file path)
380 (current-buffer))
381 (let ((o (when span
382 (make-overlay
383 (save-excursion
384 (goto-char (point-min))
385 (forward-line (1- (plist-get span :start-line)))
386 (forward-char (1- (plist-get span :start-col)))
387 (point))
388 (save-excursion
389 (goto-char (point-min))
390 (forward-line (1- (plist-get span :end-line)))
391 (forward-char (plist-get span :end-col))
392 (point))))))
393 (when o
394 (overlay-put o 'face `((:background ,sunburn-bg+1))))
395 (sit-for 0.5)
396 (when o
397 (delete-overlay o))
398 (delete-overlay p)))))
399
400 (defun haskell-debug-insert-modules (modules)
401 "Insert the list of modules."
402 (haskell-debug-insert-header "Modules")
403 (if (null modules)
404 (haskell-debug-insert-muted "No loaded modules.")
405 (progn (loop for module in modules
406 do (insert (propertize (plist-get module :module)
407 'module module
408 'face `((:weight bold)))
409 (haskell-debug-muted " - ")
410 (propertize (file-name-nondirectory (plist-get module :path))
411 'module module)))
412 (insert "\n"))))
413
414 (defun haskell-debug-insert-header (title)
415 "Insert a header title."
416 (insert (propertize title
417 'face `((:foreground ,sunburn-green)))
418 "\n\n"))
419
420 (defun haskell-debug-insert-breakpoints (breakpoints)
421 "Insert the list of breakpoints."
422 (haskell-debug-insert-header "Breakpoints")
423 (if (null breakpoints)
424 (haskell-debug-insert-muted "No active breakpoints.")
425 (loop for break in breakpoints
426 do (insert (propertize (format "%d"
427 (plist-get break :number))
428 'face `((:weight bold))
429 'break break)
430 (haskell-debug-muted " - ")
431 (propertize (plist-get break :module)
432 'break break
433 'break break)
434 (haskell-debug-muted
435 (format " (%d:%d)"
436 (plist-get (plist-get break :span) :start-line)
437 (plist-get (plist-get break :span) :start-col)))
438 "\n")))
439 (insert "\n"))
440
441 (defun haskell-debug-insert-muted (text)
442 "Insert some muted text."
443 (insert (haskell-debug-muted text)
444 "\n"))
445
446 (defun haskell-debug-muted (text)
447 "Make some muted text."
448 (propertize text 'face `((:foreground ,sunburn-grey+1))))
449
450 (defun haskell-debug-buffer-name (session)
451 "The debug buffer name for the current session."
452 (format "*debug:%s*"
453 (haskell-session-name session)))
454
455 (defun haskell-debug-start (session)
456 "Start the debug mode."
457 (setq buffer-read-only t)
458 (haskell-session-assign session)
459 (haskell-debug/refresh))
460
461 (defun haskell-debug-get-modules ()
462 "Get the list of modules currently set."
463 (let ((string (haskell-process-queue-sync-request
464 (haskell-process)
465 ":show modules")))
466 (if (string= string "")
467 (list)
468 (mapcar #'haskell-debug-parse-module
469 (split-string
470 string
471 "\n")))))
472
473 (defun haskell-debug-get-context ()
474 "Get the current context."
475 (let ((string (haskell-process-queue-sync-request
476 (haskell-process)
477 ":show context")))
478 (if (string= string "")
479 nil
480 (haskell-debug-parse-context string))))
481
482 (defun haskell-debug-navigate (direction)
483 "Navigate in DIRECTION \"back\" or \"forward\"."
484 (let ((string (haskell-process-queue-sync-request
485 (haskell-process)
486 (concat ":" direction))))
487 (let ((bindings (haskell-debug-parse-logged string)))
488 (set (make-local-variable 'haskell-debug-bindings-cache)
489 bindings)
490 (when (not bindings)
491 (message "No more %s results!" direction)))
492 (haskell-debug/refresh)))
493
494 (defun haskell-debug-parse-logged (string)
495 "Parse the logged breakpoint."
496 (cond
497 ((string= "no more logged breakpoints" string)
498 nil)
499 ((string= "already at the beginning of the history" string)
500 nil)
501 (t
502 (with-temp-buffer
503 (insert string)
504 (goto-char (point-min))
505 (list :path (progn (search-forward " at ")
506 (buffer-substring-no-properties
507 (point)
508 (1- (search-forward ":"))))
509 :span (haskell-debug-parse-span
510 (buffer-substring-no-properties
511 (point)
512 (line-end-position)))
513 :types (progn (forward-line)
514 (split-string (buffer-substring-no-properties
515 (point)
516 (point-max))
517 "\n")))))))
518
519 (defun haskell-debug-get-history ()
520 "Get the step history."
521 (let ((string (haskell-process-queue-sync-request
522 (haskell-process)
523 ":history")))
524 (if (or (string= string "")
525 (string= string "Not stopped at a breakpoint"))
526 nil
527 (if (string= string "Empty history. Perhaps you forgot to use :trace?")
528 nil
529 (let ((entries (mapcar #'haskell-debug-parse-history-entry
530 (remove-if (lambda (line) (string= "<end of history>" line))
531 (split-string
532 string
533 "\n")))))
534 (set (make-local-variable 'haskell-debug-history-cache)
535 entries)
536 entries)))))
537
538 (defun haskell-debug-parse-history-entry (string)
539 "Parse a history entry."
540 (if (string-match "^\\([-0-9]+\\)[ ]+:[ ]+\\([A-Za-z0-9_':]+\\)[ ]+(\\([^:]+\\):\\(.+?\\))$"
541 string)
542 (list :index (string-to-number (match-string 1 string))
543 :name (match-string 2 string)
544 :path (match-string 3 string)
545 :span (haskell-debug-parse-span (match-string 4 string)))
546 (error "Unable to parse history entry: %s" string)))
547
548 (defun haskell-debug-parse-context (string)
549 "Parse the context."
550 (cond
551 ((string-match "^--> \\(.+\\)\n \\(.+\\)" string)
552 (let ((name (match-string 1 string))
553 (stopped (haskell-debug-parse-stopped-at (match-string 2 string))))
554 (list :name name
555 :path (plist-get stopped :path)
556 :span (plist-get stopped :span))))))
557
558 (defun haskell-debug-get-breakpoints ()
559 "Get the list of breakpoints currently set."
560 (let ((string (haskell-process-queue-sync-request
561 (haskell-process)
562 ":show breaks")))
563 (if (string= string "No active breakpoints.")
564 (list)
565 (mapcar #'haskell-debug-parse-break-point
566 (split-string
567 string
568 "\n")))))
569
570 (defun haskell-debug-parse-stopped-at (string)
571 "Parse the location stopped at from the given string.
572
573 For example:
574
575 Stopped at /home/foo/project/src/x.hs:6:25-36
576
577 "
578 (let ((index (string-match "Stopped at \\([^:]+\\):\\(.+\\)\n?"
579 string)))
580 (when index
581 (list :path (match-string 1 string)
582 :span (haskell-debug-parse-span (match-string 2 string))
583 :types (cdr (split-string (substring string index)
584 "\n"))))))
585
586 (defun haskell-debug-parse-module (string)
587 "Parse a module and path.
588
589 For example:
590
591 X ( /home/foo/X.hs, interpreted )
592
593 "
594 (if (string-match "^\\([^ ]+\\)[ ]+( \\([^ ]+?\\), [a-z]+ )$"
595 string)
596 (list :module (match-string 1 string)
597 :path (match-string 2 string))
598 (error "Unable to parse module from string: %s"
599 string)))
600
601 (defun haskell-debug-parse-break-point (string)
602 "Parse a breakpoint number, module and location from a string.
603
604 For example:
605
606 [13] Main /home/foo/src/x.hs:(5,1)-(6,37)
607
608 "
609 (if (string-match "^\\[\\([0-9]+\\)\\] \\([^ ]+\\) \\([^:]+\\):\\(.+\\)$"
610 string)
611 (list :number (string-to-number (match-string 1 string))
612 :module (match-string 2 string)
613 :path (match-string 3 string)
614 :span (haskell-debug-parse-span (match-string 4 string)))
615 (error "Unable to parse breakpoint from string: %s"
616 string)))
617
618 (defun haskell-debug-parse-span (string)
619 "Parse a source span from a string.
620
621 Examples:
622
623 (5,1)-(6,37)
624 6:25-36
625 5:20
626
627 People like to make other people's lives interesting by making
628 variances in source span notation."
629 (cond
630 ((string-match "\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)"
631 string)
632 (list :start-line (string-to-number (match-string 1 string))
633 :start-col (string-to-number (match-string 2 string))
634 :end-line (string-to-number (match-string 1 string))
635 :end-col (string-to-number (match-string 3 string))))
636 ((string-match "\\([0-9]+\\):\\([0-9]+\\)"
637 string)
638 (list :start-line (string-to-number (match-string 1 string))
639 :start-col (string-to-number (match-string 2 string))
640 :end-line (string-to-number (match-string 1 string))
641 :end-col (string-to-number (match-string 2 string))))
642 ((string-match "(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))"
643 string)
644 (list :start-line (string-to-number (match-string 1 string))
645 :start-col (string-to-number (match-string 2 string))
646 :end-line (string-to-number (match-string 3 string))
647 :end-col (string-to-number (match-string 4 string))))
648 (t (error "Unable to parse source span from string: %s"
649 string))))
650
651 (provide 'haskell-debug)
652
653 ;; Local Variables:
654 ;; byte-compile-warnings: (not cl-functions)
655 ;; End: