adding ghc-check.el finally.

Still developping.

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

elisp/ghc-check.el

@@ -0,0 +1,135 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; ghc-check.el
+;;;
+
+;; Author:  Kazu Yamamoto <Kazu@Mew.org>
+;; 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)

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-have-errs-p) ;; fixme
-    (ghc-flymake-insert-from-warning))
+;;    (ghc-flymake-insert-from-warning))
    (t
     (message "Nothing to be done"))))
 
@@ -40,8 +40,7 @@
 
 (defun ghc-save-buffer ()
   (interactive)
-  (if (buffer-modified-p)
+  (if (buffer-modified-p) (call-interactively 'save-buffer))
-      (call-interactively 'save-buffer)
+  (ghc-check-syntax))
-    (flymake-start-syntax-check)))
 
 (provide 'ghc-command)

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-previous-key    'flymake-goto-prev-error)
-    (define-key haskell-mode-map ghc-next-key        'flymake-goto-next-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-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)