diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index fe636abff..b5b1dda45 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-check.el @@ -60,6 +61,22 @@ 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 () @@ -67,13 +84,14 @@ nil do not display errors/warnings. ;; 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) diff --git a/elisp/ghc-command.el b/elisp/ghc-command.el index df9a69f82..8c5c1b3ba 100644 --- a/elisp/ghc-command.el +++ b/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) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el index 59397bca6..dc1745963 100644 --- a/elisp/ghc-func.el +++ b/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) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 257a18e78..9c4b4824c 100644 --- a/elisp/ghc-process.el +++ b/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)