diff --git a/doc/haskell-mode.texi b/doc/haskell-mode.texi index 34078e7f0..30d0af3bb 100644 --- a/doc/haskell-mode.texi +++ b/doc/haskell-mode.texi @@ -536,6 +536,8 @@ Separate sessions per Cabal project @file{haskell-session.el}. A new inferior Haskell process handling code @file{haskell-process.el}. @item New REPL implementation similiar to SLIME/IELM +@item +Navigatable error overlays @file{haskell-interactive-mode.el}. @end itemize diff --git a/haskell-load.el b/haskell-load.el index 4ba8c4c43..7454f4419 100644 --- a/haskell-load.el +++ b/haskell-load.el @@ -92,6 +92,7 @@ actual Emacs buffer of the module being loaded." (cursor (haskell-process-response-cursor process)) (warning-count 0)) (haskell-process-set-response-cursor process 0) + (haskell-check-remove-overlays module-buffer) (while (haskell-process-errors-warnings module-buffer session process buffer) (setq warning-count (1+ warning-count))) (haskell-process-set-response-cursor process cursor) @@ -265,10 +266,135 @@ actual Emacs buffer of the module being loaded." (modules (split-string modules-string ", "))) (cons modules modules-string))) +(defface haskell-error-face + '((((supports :underline (:style wave))) + :underline (:style wave :color "#dc322f")) + (t + :inherit error)) + "Face used for marking error lines." + :group 'haskell-mode) + +(defface haskell-warning-face + '((((supports :underline (:style wave))) + :underline (:style wave :color "#b58900")) + (t + :inherit warning)) + "Face used for marking warning lines." + :group 'haskell-mode) + +(defface haskell-hole-face + '((((supports :underline (:style wave))) + :underline (:style wave :color "#6c71c4")) + (t + :inherit warning)) + "Face used for marking hole lines." + :group 'haskell-mode) + +(defvar haskell-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark))) +(defvar haskell-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark))) +(defvar haskell-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar))) + +(defun haskell-check-overlay-p (ovl) + (overlay-get ovl 'haskell-check)) + +(defun haskell-check-filter-overlays (xs) + (cl-remove-if-not 'haskell-check-overlay-p xs)) + +(defun haskell-check-remove-overlays (buffer) + (with-current-buffer buffer + (remove-overlays (point-min) (point-max) 'haskell-check t))) + +(defmacro with-overlay-properties (proplist ovl &rest body) + "Evaluate BODY with names in PROPLIST bound to the values of +correspondingly-named overlay properties of OVL." + (let ((ovlvar (cl-gensym "OVL-"))) + `(let* ((,ovlvar ,ovl) + ,@(mapcar (lambda (p) `(,p (overlay-get ,ovlvar ',p))) proplist)) + ,@body))) + +(defun overlay-start> (o1 o2) + (> (overlay-start o1) (overlay-start o2))) +(defun overlay-start< (o1 o2) + (< (overlay-start o1) (overlay-start o2))) + +(defun first-overlay-in-if (test beg end) + (let ((ovls (cl-remove-if-not test (overlays-in beg end)))) + (cl-first (sort (cl-copy-list ovls) 'overlay-start<)))) + +(defun last-overlay-in-if (test beg end) + (let ((ovls (cl-remove-if-not test (overlays-in beg end)))) + (cl-first (sort (cl-copy-list ovls) 'overlay-start>)))) + +(defun haskell-error-overlay-briefly (ovl) + (with-overlay-properties (haskell-msg haskell-msg-type) ovl + (cond ((not (eq haskell-msg-type 'warning)) + haskell-msg) + ((string-prefix-p "Warning:\n " haskell-msg) + (cl-subseq haskell-msg 13)) + (t (error "Invariant failed: a warning message from GHC has unexpected form: %s." haskell-msg))))) + +(defun haskell-goto-error-overlay (ovl) + (cond (ovl + (goto-char (overlay-start ovl)) + (haskell-mode-message-line (haskell-error-overlay-briefly ovl))) + (t + (message "No further notes from Haskell compiler.")))) + +(defun haskell-goto-prev-error () + (interactive) + (haskell-goto-error-overlay + (let ((ovl-at (cl-first (haskell-check-filter-overlays (overlays-at (point)))))) + (or (last-overlay-in-if 'haskell-check-overlay-p + (point-min) (if ovl-at (overlay-start ovl-at) (point))) + ovl-at)))) + +(defun haskell-goto-next-error () + (interactive) + (haskell-goto-error-overlay + (let ((ovl-at (cl-first (haskell-check-filter-overlays (overlays-at (point)))))) + (or (first-overlay-in-if 'haskell-check-overlay-p + (if ovl-at (overlay-end ovl-at) (point)) (point-max)) + ovl-at)))) + +(defun haskell-check-paint-overlay (buffer error-from-this-file-p line msg file type hole coln) + (with-current-buffer buffer + (let (beg end) + (goto-char (point-min)) + ;; XXX: we can avoid excess buffer walking by relying on the maybe-fact that + ;; GHC sorts error messages by line number, maybe. + (cond + (error-from-this-file-p + (forward-line (1- line)) + (forward-char (1- coln)) + (setq beg (point)) + (if (eq type 'hole) + (forward-char (length hole)) + (skip-chars-forward "^[:space:]" (line-end-position))) + (setq end (point))) + (t + (setq beg (point)) + (forward-line) + (setq end (point)))) + (let ((ovl (make-overlay beg end))) + (overlay-put ovl 'haskell-check t) + (overlay-put ovl 'haskell-file file) + (overlay-put ovl 'haskell-msg msg) + (overlay-put ovl 'haskell-msg-type type) + (overlay-put ovl 'help-echo msg) + (overlay-put ovl 'haskell-hole hole) + (cl-destructuring-bind (face fringe) (cl-case type + (warning (list 'haskell-warning-face haskell-check-warning-fringe)) + (hole (list 'haskell-hole-face haskell-check-hole-fringe)) + (error (list 'haskell-error-face haskell-check-error-fringe))) + (overlay-put ovl 'before-string fringe) + (overlay-put ovl 'face face)))))) + (defun haskell-process-errors-warnings (module-buffer session process buffer &optional return-only) - "Trigger handling type errors or warnings. Either prints the + "Trigger handling type errors or warnings. Either prints the messages in the interactive buffer or if CONT is specified, -passes the error onto that." +passes the error onto that. + +When MODULE-BUFFER is non-NIL, paint error overlays." (cond ((haskell-process-consume process @@ -302,27 +428,31 @@ passes the error onto that." (- (haskell-process-response-cursor process) 1)) (let* ((buffer (haskell-process-response process)) (file (match-string 1 buffer)) - (location (match-string 2 buffer)) + (location-raw (match-string 2 buffer)) (error-msg (match-string 3 buffer)) - (warning (string-match "^Warning:" error-msg)) - (splice (string-match "^Splicing " error-msg)) + (type (cond ((string-match "^Warning:" error-msg) 'warning) + ((string-match "^Splicing " error-msg) 'splice) + (t 'error))) + (critical (not (eq type 'warning))) + ;; XXX: extract hole information, pass down to `haskell-check-paint-overlay' (final-msg (format "%s:%s: %s" (haskell-session-strip-dir session file) - location - error-msg))) + location-raw + error-msg)) + (location (haskell-process-parse-error (concat file ":" location-raw ": x"))) + (line (plist-get location :line)) + (col1 (plist-get location :col))) + (when module-buffer + (haskell-check-paint-overlay module-buffer (string= (file-truename (buffer-file-name module-buffer)) (file-truename file)) + line error-msg file type nil col1)) (if return-only - (let* ((location (haskell-process-parse-error (concat file ":" location ": x"))) - (file (plist-get location :file)) - (line (plist-get location :line)) - (col1 (plist-get location :col))) - (list :file file :line line :col col1 :msg error-msg :type (if warning 'warning 'error))) - (progn (funcall (cond (warning - 'haskell-interactive-mode-compile-warning) - (splice - 'haskell-interactive-mode-compile-splice) - (t 'haskell-interactive-mode-compile-error)) + (list :file file :line line :col col1 :msg error-msg :type type) + (progn (funcall (cl-case type + (warning 'haskell-interactive-mode-compile-warning) + (splice 'haskell-interactive-mode-compile-splice) + (error 'haskell-interactive-mode-compile-error)) session final-msg) - (unless warning + (when critical (haskell-mode-message-line final-msg)) (haskell-process-trigger-suggestions session diff --git a/haskell.el b/haskell.el index eaa92b68e..706683853 100644 --- a/haskell.el +++ b/haskell.el @@ -49,6 +49,8 @@ (define-key map (kbd "C-c C-x") 'haskell-process-cabal) (define-key map [?\C-c ?\C-b] 'haskell-interactive-switch) (define-key map [?\C-c ?\C-z] 'haskell-interactive-switch) + (define-key map (kbd "M-n") 'haskell-goto-next-error) + (define-key map (kbd "M-p") 'haskell-goto-prev-error) map) "Keymap for using haskell-interactive-mode.")