diff --git a/elisp/Makefile b/elisp/Makefile index 207e5d3..caabdba 100644 --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,4 +1,4 @@ -SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el \ +SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el \ ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el EMACS = emacs DETECT = xemacs diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el new file mode 100644 index 0000000..1744c21 --- /dev/null +++ b/elisp/ghc-check.el @@ -0,0 +1,135 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc-check.el +;;; + +;; Author: Kazu Yamamoto +;; Created: Mar 9, 2014 + +;;; Code: + +(require 'ghc-func) + +(defvar-local ghc-check-running nil) +(defvar-local ghc-check-process-name nil) +(defvar-local ghc-check-original-buffer nil) +(defvar-local ghc-check-original-file nil) + +(defun ghc-check-get-process-name () + (let ((file (buffer-file-name))) + (with-temp-buffer + (ghc-call-process ghc-module-command nil t nil "debug" file) + (goto-char (point-min)) + (when (re-search-forward "^Root directory: +\\(.*\\)$" nil t) + (match-string-no-properties 1))))) + +(defun ghc-check-syntax () + (unless ghc-check-process-name + (setq ghc-check-process-name (ghc-check-get-process-name))) + (if (null ghc-check-process-name) + (message "Can't check") + (let* ((cbuf (current-buffer)) + (name ghc-check-process-name) + (buf (get-buffer-create (concat " ghc-modi:" name))) + (file (buffer-file-name)) + (cpro (get-process name))) + (with-current-buffer buf + (unless ghc-check-running + (setq ghc-check-running t) + (setq ghc-check-original-buffer cbuf) + (setq ghc-check-original-file file) + (erase-buffer) + (let ((pro (ghc-check-get-process cpro name buf))) + (process-send-string pro (concat file "\n")))))))) + +(defun ghc-check-get-process (cpro name buf) + (cond + ((not cpro) + (ghc-check-start-process name buf)) + ((not (eq (process-status cpro) 'run)) + (delete-process cpro) + (ghc-check-start-process name buf)) + (t cpro))) + +(defun ghc-check-start-process (name buf) + (let ((pro (start-file-process name buf "ghc-modi"))) + (set-process-filter pro 'ghc-check-process-filter) + (set-process-sentinel pro 'ghc-check-process-sentinel) + (set-process-query-on-exit-flag pro nil) + pro)) + +(ghc-defstruct hilit-info file line col msg) + +(defun ghc-check-process-filter (process string) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string) + (forward-line -1) + (cond + ((looking-at "^NG$") + (setq ghc-check-running nil) + (message "An error happens")) + ((looking-at "^OK$") + (goto-char (point-min)) + (let ((regex "^\\(.*\\):\\([0-9]+\\):\\([0-9]+\\): *\\(.+\\)") + info infos) + (while (re-search-forward regex nil t) + (setq info (ghc-make-hilit-info + :file (match-string 1) + :line (string-to-number (match-string 2)) + :col (string-to-number (match-string 3)) + :msg (match-string 4))) + (setq infos (cons info infos))) + (setq infos (nreverse infos)) + (cond + (infos + (ghc-check-highlight-original-buffer ghc-check-original-buffer infos)) + (t + (message "No changes"))) + (setq ghc-check-running nil)))))) + +(defun ghc-check-process-sentinel () + ) + +(defun ghc-check-highlight-original-buffer (buf infos) + (message "%s" infos) + (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)) + beg end ovl) + (goto-line line) + (while (eq (char-after) 32) (forward-char)) + (setq beg (point)) + (forward-line) + (setq end (1- (point))) + (setq ovl (make-overlay beg end)) + (overlay-put ovl 'ghc-check t) + (overlay-put ovl 'ghc-msg msg) ;; should be list + (let ((face (if (string-match "^Error" msg) + 'ghc-face-error + 'ghc-face-warn))) + (overlay-put ovl 'face face))))))) + +;; stolen from flymake.el +(defface ghc-face-error + '((((supports :underline (:style wave))) + :underline (:style wave :color "Red1")) + (t + :inherit error)) + "Face used for marking error lines." + :group 'ghc) + +(defface ghc-face-warn + '((((supports :underline (:style wave))) + :underline (:style wave :color "DarkOrange")) + (t + :inherit warning)) + "Face used for marking warning lines." + :group 'ghc) + + +(provide 'ghc-check) diff --git a/elisp/ghc-command.el b/elisp/ghc-command.el index e3e394f..f7c8b0c 100644 --- a/elisp/ghc-command.el +++ b/elisp/ghc-command.el @@ -8,15 +8,15 @@ ;;; Code: -(require 'ghc-flymake) +(require 'ghc-check) (defun ghc-insert-template () (interactive) (cond ((bobp) (ghc-insert-module-template)) - ((ghc-flymake-have-errs-p) - (ghc-flymake-insert-from-warning)) +;; ((ghc-flymake-have-errs-p) ;; fixme +;; (ghc-flymake-insert-from-warning)) (t (message "Nothing to be done")))) @@ -40,8 +40,7 @@ (defun ghc-save-buffer () (interactive) - (if (buffer-modified-p) - (call-interactively 'save-buffer) - (flymake-start-syntax-check))) + (if (buffer-modified-p) (call-interactively 'save-buffer)) + (ghc-check-syntax)) (provide 'ghc-command) diff --git a/elisp/ghc.el b/elisp/ghc.el index 63e7976..fe7450e 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -8,8 +8,6 @@ ;; ;; (autoload 'ghc-init "ghc" nil t) ;; (add-hook 'haskell-mode-hook (lambda () (ghc-init))) -;; Or -;; (add-hook 'haskell-mode-hook (lambda () (ghc-init) (flymake-mode))) ;;; Code: @@ -21,7 +19,7 @@ (require 'ghc-comp) (require 'ghc-doc) (require 'ghc-info) -(require 'ghc-flymake) +(require 'ghc-check) (require 'ghc-command) (require 'ghc-ins-mod) (require 'ghc-indent) @@ -74,15 +72,15 @@ (define-key haskell-mode-map ghc-type-key 'ghc-show-type) (define-key haskell-mode-map ghc-info-key 'ghc-show-info) (define-key haskell-mode-map ghc-expand-key 'ghc-expand-th) - (define-key haskell-mode-map ghc-jump-key 'ghc-flymake-jump) +;; (define-key haskell-mode-map ghc-jump-key 'ghc-flymake-jump) ;; fixme (define-key haskell-mode-map ghc-import-key 'ghc-import-module) - (define-key haskell-mode-map ghc-previous-key 'flymake-goto-prev-error) - (define-key haskell-mode-map ghc-next-key 'flymake-goto-next-error) - (define-key haskell-mode-map ghc-help-key 'ghc-flymake-display-errors) +;; (define-key haskell-mode-map ghc-previous-key 'flymake-goto-prev-error) +;; (define-key haskell-mode-map ghc-next-key 'flymake-goto-next-error) +;; (define-key haskell-mode-map ghc-help-key 'ghc-flymake-display-errors) (define-key haskell-mode-map ghc-insert-key 'ghc-insert-template) (define-key haskell-mode-map ghc-sort-key 'ghc-sort-lines) (define-key haskell-mode-map ghc-check-key 'ghc-save-buffer) - (define-key haskell-mode-map ghc-toggle-key 'ghc-flymake-toggle-command) +;; (define-key haskell-mode-map ghc-toggle-key 'ghc-flymake-toggle-command) (define-key haskell-mode-map ghc-module-key 'ghc-insert-module) (define-key haskell-mode-map ghc-hoogle-key 'haskell-hoogle) (define-key haskell-mode-map ghc-shallower-key 'ghc-make-indent-shallower)