elisp: Add option to jump to first error after save

elisp/ghc-check.el

@@ -1,3 +1,4 @@
+;;; -*- lexical-binding: t -*-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; ghc-check.el
@@ -60,20 +61,37 @@ nil            do not display errors/warnings.
 'other-buffer  display errors/warnings in the a new buffer"
 )
 
+(defcustom ghc-check-jump-to-message nil
+  "After checking a buffer jump to the first hole/warning/error reported."
+  :type 'boolean
+  :group 'ghc-mod)
+
+(defcustom ghc-check-jump-display-message nil
+  "After jumping to a location also display the error message."
+  :type 'boolean
+  :group 'ghc-mod)
+
+(defcustom ghc-check-jump-follow-other-files nil
+  "When attempting to jump to an error that is from another file
+open this file and jump to the error inside it."
+  :type 'boolean
+  :group 'ghc-mod)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun ghc-check-syntax ()
   (interactive)
   ;; Only check syntax of visible buffers
   (when (and (buffer-file-name)
 	     (file-exists-p (buffer-file-name)))
+    (setq ghc-point@syntax-check (point))
     (ghc-with-process (ghc-check-send)
 		      'ghc-check-callback
 		      (lambda () (setq mode-line-process " -:-")))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(ghc-defstruct hilit-info file line msg err hole coln)
+(ghc-defstruct msg-info file line coln msg type)
 
 (defun ghc-check-send ()
   (let ((file (buffer-file-name)))
@@ -107,20 +125,19 @@ nil            do not display errors/warnings.
 	(let ((len (length infos)))
 	  (if (= len 0)
 	      (setq mode-line-process "")
-	    (let* ((errs (ghc-filter 'ghc-hilit-info-get-err infos))
+	    (let* ((errs (ghc-filter (lambda (info) (eq 'err (ghc-msg-info-get-type info))) infos))
 		   (elen (length errs))
 		   (wlen (- len elen)))
 	      (setq mode-line-process (format " %d:%d" elen wlen)))))
 	(force-mode-line-update))))
    (t
     (let* ((err (ghc-unescape-string (buffer-substring-no-properties (+ (point) 3) (point-max))))
-	   (info (ghc-make-hilit-info
+	   (info (ghc-make-msg-info
 		  :file "Fail errors:"
 		  :line 0
 		  :coln 0
 		  :msg  err
-		  :err  t
-		  :hole nil))
+		  :type 'err))
 	   (infos (list info))
 	   (file ghc-process-original-file)
 	   (buf ghc-process-original-buffer))
@@ -143,62 +160,94 @@ nil            do not display errors/warnings.
                (hole (save-match-data
                         (when (string-match "Found hole .\\(_[_[:alnum:]]*\\)." msg)
                               (match-string 1 msg))))
-	       (info (ghc-make-hilit-info
+	       (info (ghc-make-msg-info
 		      :file file
 		      :line line
                       :coln coln
 		      :msg  msg
-		      :err  (and (not wrn) (not hole))
-                      :hole hole)))
+		      :type (if wrn 'warn (if hole 'hole 'err)))))
 	  (unless (member info infos)
 	    (ghc-add infos info)))))))
 
+(defun ghc-check-add-overlay (i ofile info)
+  (pcase-let ((`(,file ,line ,coln ,msg ,type) info))
+    (let (beg end ovl)
+      (goto-char (point-min))
+      (cond
+       ((file-equal-p ofile file)
+	(if (eq type 'hole)
+	    (progn
+	      (forward-line (1- line))
+	      (forward-char (1- coln))
+	      (setq beg (point))
+	      (forward-word)
+	      (setq end (point)))
+	  (progn
+	    (forward-line (1- line))
+	    (forward-char (1- coln))
+	    (setq beg (point))
+	    (forward-sexp)
+	    ;; (skip-chars-forward "^[:space:]" (line-end-position))
+	    (setq end (point)))))
+       (t
+	(setq beg (point))
+	(forward-line)
+	(setq end (point))))
+
+      (setq ovl (make-overlay beg end))
+
+      (overlay-put ovl 'ghc-check t)
+      (overlay-put ovl 'ghc-index i)
+
+      (overlay-put ovl 'ghc-info info)
+
+      ; todo: remove
+      (overlay-put ovl 'ghc-file file)
+      (overlay-put ovl 'ghc-line line)
+      (overlay-put ovl 'ghc-coln coln)
+      (overlay-put ovl 'ghc-msg msg)
+      (overlay-put ovl 'help-echo msg)
+
+      (overlay-put ovl 'before-string
+		   (pcase type
+		     (`warn ghc-check-warning-fringe)
+		     (`hole ghc-check-hole-fringe )
+		     (`err  ghc-check-error-fringe)))
+
+      (overlay-put ovl 'face
+		   (pcase type
+		     (`warn 'ghc-face-warn)
+		     (`hole 'ghc-face-hole )
+		     (`err  'ghc-face-error))))))
+
 (defun ghc-check-highlight-original-buffer (ofile buf infos)
   (ghc-with-current-buffer buf
     (remove-overlays (point-min) (point-max) 'ghc-check t)
     (save-excursion
       (goto-char (point-min))
-      (dolist (info infos)
-	(let ((line (ghc-hilit-info-get-line info))
-	      (msg  (ghc-hilit-info-get-msg  info))
-	      (file (ghc-hilit-info-get-file info))
-	      (err  (ghc-hilit-info-get-err  info))
-              (hole (ghc-hilit-info-get-hole info))
-              (coln (ghc-hilit-info-get-coln info))
-	      beg end ovl)
-	  ;; FIXME: This is the Shlemiel painter's algorithm.
-	  ;; If this is a bottleneck for a large code, let's fix.
-	  (goto-char (point-min))
-	  (cond
-	   ((file-equal-p ofile file)
-            (if hole
-              (progn
-                (forward-line (1- line))
-                (forward-char (1- coln))
-                (setq beg (point))
-                (forward-char (length hole))
-                (setq end (point)))
-              (progn
-                (forward-line (1- line))
-                (forward-char (1- coln))
-                (setq beg (point))
-		(forward-sexp)
-                ;; (skip-chars-forward "^[:space:]" (line-end-position))
-                (setq end (point)))))
-	   (t
-	    (setq beg (point))
-	    (forward-line)
-	    (setq end (point))))
-	  (setq ovl (make-overlay beg end))
-	  (overlay-put ovl 'ghc-check t)
-	  (overlay-put ovl 'ghc-file file)
-	  (overlay-put ovl 'ghc-msg msg)
-	  (overlay-put ovl 'help-echo msg)
-          (overlay-put ovl 'ghc-hole hole)
-	  (let ((fringe (if err ghc-check-error-fringe (if hole ghc-check-hole-fringe ghc-check-warning-fringe)))
-		(face (if err 'ghc-face-error (if hole 'ghc-face-hole 'ghc-face-warn))))
-	    (overlay-put ovl 'before-string fringe)
-	    (overlay-put ovl 'face face)))))))
+      (let ((i 1))
+	(dolist (info infos)
+	  (ghc-check-add-overlay i ofile info)
+	  (setq i (1+ i)) )))
+
+    (when (and ghc-check-jump-to-message (equal (point) ghc-point@syntax-check))
+      (ghc-goto-first-error))))
+
+(defun ghc-check-jump-to-info (info &optional ofile)
+  (cl-block nil
+    (pcase-let ((`(,file ,line ,coln ,msg ,err ,hole) info))
+      (unless hole
+	(unless (file-equal-p (or ofile (buffer-file-name)) file)
+	  (if ghc-check-jump-follow-other-files
+	      (find-file file)
+	    (cl-return)))
+
+	(push-mark (point))
+	(goto-char (point-min))
+	(forward-line (1- line))
+	(forward-char (1- coln))
+	(when ghc-check-jump-display-message
+	  (ghc-display-info-to-buffer info))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -222,7 +271,29 @@ nil            do not display errors/warnings.
 	    (ghc-add errs msg)))
 	(ghc-make-file-msgs :file file :msgs (nconc errs wrns))))))
 
-(defun ghc-display-errors ()
+(defun ghc-sort-errors-before-warnings (ovls)
+  (ghc-sort
+   ovls
+   (ghc-on
+    '<=
+    (lambda (ovl)
+      (pcase (ghc-msg-info-get-type (overlay-get ovl 'ghc-info))
+	(`err  0)
+	(`hole 1)
+	(`warn 2))))))
+
+(defun ghc-display-info-to-buffer (info)
+  (if (not info)
+      (message "No errors or warnings")
+    (pcase-let ((`(,file ,line ,coln ,msg ,type) info))
+      (ghc-display
+       nil
+       (lambda ()
+	 (insert file "\n\n")
+	 (mapc (lambda (x) (insert x "\n\n")) (list msg)))))))
+
+
+(defun ghc-display-errors-to-buffer ()
   (interactive)
   (let ((file-msgs (ghc-get-errors-over-warnings)))
     (if (null file-msgs)
@@ -313,6 +384,24 @@ nil            do not display errors/warnings.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(defun ghc-display-errors (&rest args)
+  (interactive)
+  (apply
+   (pcase ghc-display-error
+     (`minibuffer   'ghc-display-errors-to-minibuf)
+     ((or `other-buffer _) 'ghc-display-errors-to-buffer))
+   args))
+
+(defun ghc-goto-first-error ()
+  (interactive)
+  (let* ((ovls0 (overlays-in (point-min) (point-max)))
+         (ovls1
+	  (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls0))
+	 (ovls2 (sort ovls1 (ghc-on '>= (lambda (ovl) (overlay-get ovl 'ghc-index)))))
+	 (ovls3 (ghc-sort-errors-before-warnings ovls2))
+         (first_error (first ovls3)))
+    (if first_error (ghc-check-jump-to-info (overlay-get first_error 'ghc-info)))))
+
 (defun ghc-goto-prev-error ()
   (interactive)
   (let* ((here (point))
@@ -324,7 +413,7 @@ nil            do not display errors/warnings.
     (if pnts (goto-char (apply 'max pnts))))
   (cond
    ((eq ghc-display-error 'minibuffer) (ghc-display-errors-to-minibuf))
-   ((eq ghc-display-error 'other-buffer) (ghc-display-errors))))
+   ((eq ghc-display-error 'other-buffer) (ghc-display-errors-to-buffer))))
 
 (defun ghc-goto-next-error ()
   (interactive)
@@ -337,7 +426,7 @@ nil            do not display errors/warnings.
     (if pnts (goto-char (apply 'min pnts))))
   (cond
    ((eq ghc-display-error 'minibuffer) (ghc-display-errors-to-minibuf))
-   ((eq ghc-display-error 'other-buffer) (ghc-display-errors))))
+   ((eq ghc-display-error 'other-buffer) (ghc-display-errors-to-buffer))))
 
 (defun ghc-goto-prev-hole ()
   (interactive)

elisp/ghc-command.el

@@ -83,15 +83,4 @@
       (delete-region beg (point))
       (insert "import " mod " (" syms ")\n"))))
 
-(defun ghc-save-buffer ()
-  (interactive)
-  ;; fixme: better way then saving?
-  (if ghc-check-command ;; hlint
-      (if (buffer-modified-p)
-	  (call-interactively 'save-buffer))
-    (unless buffer-read-only
-      (set-buffer-modified-p t)
-      (call-interactively 'save-buffer)))
-  (ghc-check-syntax))
-
 (provide 'ghc-command)

elisp/ghc-func.el

@@ -1,3 +1,4 @@
+;;; -*- lexical-binding: t -*-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; ghc-func.el
@@ -31,8 +32,6 @@
       (while (search-forward from nil t)
 	(replace-match to)))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 (defun ghc-unescape-string (str)
   (with-temp-buffer
     (insert str)
@@ -42,8 +41,6 @@
     (while (search-forward "\\\\" nil t) (replace-match "\\" nil t))
     (buffer-substring-no-properties (point-min) (point-max))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 (defmacro ghc-add (sym val)
   `(setq ,sym (cons ,val ,sym)))
 
@@ -52,13 +49,20 @@
     (if var (set var (car vals))) ;; var can be nil to skip
     (setq vals (cdr vals))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 (defun ghc-filter (pred lst)
   (let (ret)
     (dolist (x lst (reverse ret))
       (if (funcall pred x) (ghc-add ret x)))))
 
+(defun ghc-sort (xs f)
+  (sort (copy-tree xs) f))
+
+;; on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
+;; (.*.) `on` f = \x y -> f x .*. f y
+
+(defun ghc-on (g f)
+  (lambda (x y) (funcall g (funcall f x) (funcall f y))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun ghc-uniq-lol (lol)

elisp/ghc-process.el

@@ -169,17 +169,25 @@
 		(delete-region 1 end)))))
 	(goto-char (point-max))
 	(forward-line -1)
-	(cond
-	 ((looking-at "^OK$")
-	  (delete-region (point) (point-max))
-	  (setq ghc-process-file-mapping nil)
-	  (when ghc-process-async-after-callback
-	    (goto-char (point-min))
-	    (funcall ghc-process-async-after-callback 'ok)
-	    (setq ghc-process-running nil)))
-	 ((looking-at "^NG ")
-	  (funcall ghc-process-async-after-callback 'ng)
-	  (setq ghc-process-running nil)))))))
+
+	(cl-flet ((async-after-callback ()
+	        (condition-case err
+		    (progn
+		      (funcall ghc-process-async-after-callback 'ok)
+		      (setq ghc-process-running nil))
+		  (error
+		   (setq ghc-process-running nil)
+		   (signal (car err) (cdr err))))))
+	  (cond
+	   ((looking-at "^OK$")
+	    (delete-region (point) (point-max))
+	    (setq ghc-process-file-mapping nil)
+	    (when ghc-process-async-after-callback
+	      (goto-char (point-min))
+	      (async-after-callback)
+	      ))
+	   ((looking-at "^NG ")
+	    (async-after-callback))))))))
 
 (defun ghc-process-sentinel (_process _event)
   (setq ghc-process-running nil)