hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

check results are displayed in mode-line.

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-03-25 16:40:07 +09:00
parent 58b64cc9e2
commit a16dc3d040
1 changed files with 25 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
elisp/ghc-check.el
View File

@ -42,7 +42,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(ghc-defstruct hilit-info file line col msg) (ghc-defstruct hilit-info file line col msg err)
(defun ghc-check-send () (defun ghc-check-send ()
(concat "check " ghc-process-original-file "\n")) (concat "check " ghc-process-original-file "\n"))
@ -51,12 +51,18 @@
(let ((regex "^\\([^\n\0]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\(.+\\)") (let ((regex "^\\([^\n\0]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\(.+\\)")
info infos) info infos)
(while (re-search-forward regex nil t) (while (re-search-forward regex nil t)
(setq info (ghc-make-hilit-info (let* ((file (match-string 1))
:file (match-string 1) (line (string-to-number (match-string 2)))
:line (string-to-number (match-string 2)) (col (string-to-number (match-string 3)))
:col (string-to-number (match-string 3)) (msg (match-string 4))
:msg (match-string 4))) (err (not (string-match "^Warning" msg)))
(setq infos (cons info infos))) (info (ghc-make-hilit-info
:file file
:line line
:col col
:msg msg
:err err)))
(setq infos (cons info infos))))
(setq infos (nreverse infos)) (setq infos (nreverse infos))
(cond (cond
(infos (infos
@ -65,7 +71,15 @@
(ghc-check-highlight-original-buffer file buf infos))) (ghc-check-highlight-original-buffer file buf infos)))
(t (t
(with-current-buffer ghc-process-original-buffer (with-current-buffer ghc-process-original-buffer
(remove-overlays (point-min) (point-max) 'ghc-check t)))))) (remove-overlays (point-min) (point-max) 'ghc-check t))))
(with-current-buffer ghc-process-original-buffer
(let ((len (length infos)))
(if (= len 0)
(setq mode-line-process "")
(let* ((errs (ghc-filter 'ghc-hilit-info-get-err infos))
(elen (length errs))
(wlen (- len elen)))
(setq mode-line-process (format " %d:%d" elen wlen))))))))
(defun ghc-check-highlight-original-buffer (ofile buf infos) (defun ghc-check-highlight-original-buffer (ofile buf infos)
(with-current-buffer buf (with-current-buffer buf
@ -74,8 +88,9 @@
(goto-char (point-min)) (goto-char (point-min))
(dolist (info infos) (dolist (info infos)
(let ((line (ghc-hilit-info-get-line info)) (let ((line (ghc-hilit-info-get-line info))
(msg (ghc-hilit-info-get-msg info)) (msg (ghc-hilit-info-get-msg info))
(file (ghc-hilit-info-get-file info)) (file (ghc-hilit-info-get-file info))
(err (ghc-hilit-info-get-err info))
beg end ovl) beg end ovl)
;; FIXME: This is the Shlemiel painter's algorithm. ;; FIXME: This is the Shlemiel painter's algorithm.
;; If this is a bottleneck for a large code, let's fix. ;; If this is a bottleneck for a large code, let's fix.
@ -95,9 +110,7 @@
(overlay-put ovl 'ghc-check t) (overlay-put ovl 'ghc-check t)
(overlay-put ovl 'ghc-file file) (overlay-put ovl 'ghc-file file)
(overlay-put ovl 'ghc-msg msg) ;; should be list (overlay-put ovl 'ghc-msg msg) ;; should be list
(let ((face (if (string-match "^Warning" msg) (let ((face (if err 'ghc-face-error 'ghc-face-warn)))
'ghc-face-warn
'ghc-face-error)))
(overlay-put ovl 'face face))))))) (overlay-put ovl 'face face)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;