Clean up ghc-mod's Emacs frontend

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-comp.el

@@ -3,13 +3,15 @@
 ;;; ghc-comp.el
 ;;;
 
-;; Author:  Kazu Yamamoto <Kazu@Mew.org>
+;; Author:  Kazu Yamamoto <Kazu@Mew.org>, Daniel Gröber <dxld@darkboxed.org>
 ;; Created: Sep 25, 2009
+;; Revised: Aug 16, 2014
 
 ;;; Code:
 
 (require 'ghc-func)
 (require 'ghc-rewrite)
+(require 'ghc-process)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -66,21 +68,24 @@ unloaded modules are loaded")
 
 (defvar ghc-loaded-module nil)
 
+
+(defvar ghc-mod-comp-syms '(ghc-module-names
+                            ghc-language-extensions
+                            ghc-option-flags
+                            ;; hard coded in GHCMod.hs
+                            ghc-keyword-Prelude
+                            ghc-keyword-Control.Applicative
+                            ghc-keyword-Control.Exception
+                            ghc-keyword-Control.Monad
+                            ghc-keyword-Data.Char
+                            ghc-keyword-Data.List
+                            ghc-keyword-Data.Maybe
+                            ghc-keyword-System.IO) )
+
 (defun ghc-comp-init ()
-  (let* ((syms '(ghc-module-names
-		 ghc-language-extensions
-		 ghc-option-flags
-		 ;; hard coded in GHCMod.hs
-		 ghc-keyword-Prelude
-		 ghc-keyword-Control.Applicative
-		 ghc-keyword-Control.Exception
-		 ghc-keyword-Control.Monad
-		 ghc-keyword-Data.Char
-		 ghc-keyword-Data.List
-		 ghc-keyword-Data.Maybe
-		 ghc-keyword-System.IO))
-	 (vals (ghc-boot (length syms))))
-    (ghc-set syms vals))
+  (let* ((vals (ghc-boot (length ghc-mod-comp-syms))))
+    (ghc-set ghc-mod-comp-syms vals))
+
   (ghc-add ghc-module-names "qualified")
   (ghc-add ghc-module-names "hiding")
   ;; hard coded in GHCMod.hs
@@ -91,7 +96,14 @@ unloaded modules are loaded")
 			"Data.Char"
 			"Data.List"
 			"Data.Maybe"
-			"System.IO")))
+			"System.IO"))
+  (ghc-import-module) )
+
+(defun ghc-comp-deinit ()
+  (mapcar (lambda (s) (set s nil)) ghc-mod-comp-syms)
+  (setq ghc-loaded-module nil)
+  (setq ghc-merged-keyword nil) )
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;

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)
@@ -234,13 +238,17 @@
      (goto-char (point-max))
      ,@body))
 
-(defun ghc-call-process (cmd x y z &rest args)
-  (apply 'call-process cmd x y z args)
-  (when ghc-debug
-    (let ((cbuf (current-buffer)))
-      (ghc-with-debug-buffer
-       (insert (format "%% %s %s\n" cmd (mapconcat 'identity args " ")))
-       (insert-buffer-substring cbuf)))))
+(defun ghc-call-process (cmd infile destination display &rest args)
+  (let ((rv (apply 'call-process cmd infile destination display args)))
+    (unwind-protect
+	(when (/= 0 rv)
+	  (error "Command failed (exit code %d): %s %s"
+		 rv cmd (mapconcat 'identity args " ")))
+      (when ghc-debug
+	(let ((cbuf (current-buffer)))
+	  (ghc-with-debug-buffer
+	   (insert (format "%% %s %s -> exit code %d\n" cmd (mapconcat 'identity args " ") rv))
+	   (insert-buffer-substring cbuf)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

elisp/ghc-info.el

@@ -3,8 +3,9 @@
 ;;; ghc-info.el
 ;;;
 
-;; Author:  Kazu Yamamoto <Kazu@Mew.org>
+;; Author:  Kazu Yamamoto <Kazu@Mew.org>, Daniel Gröber <dxld@darkboxed.org>
 ;; Created: Nov 15, 2010
+;; Revised: Aug 16, 2014
 
 ;;; Code:
 
@@ -31,9 +32,8 @@
 ;;; type
 ;;;
 
-(defvar ghc-type-overlay nil)
-
-(make-variable-buffer-local 'ghc-type-overlay)
+(defvar-local ghc-type-overlay nil "Overlay marking the extent of the
+expression who's type was just analyzed.")
 
 (defun ghc-type-set-ix (n)
   (overlay-put ghc-type-overlay 'ix n))
@@ -57,12 +57,20 @@
 
 (defun ghc-type-init ()
   (setq ghc-type-overlay (make-overlay 0 0))
+  (overlay-put ghc-type-overlay 'ghc-type t)
   (overlay-put ghc-type-overlay 'face 'region)
   (ghc-type-clear-overlay)
   (setq after-change-functions
 	(cons 'ghc-type-clear-overlay after-change-functions))
   (add-hook 'post-command-hook 'ghc-type-post-command-hook))
 
+(defun ghc-type-deinit ()
+  (remove-hook 'post-command-hook 'ghc-type-post-command-hook)
+  (setq after-change-functions
+	(delq 'ghc-type-clear-overlay after-change-functions))
+  (ghc-type-clear-overlay)
+  (remove-overlays (point-min) (point-max) 'ghc-type t))
+
 (defun ghc-type-clear-overlay (&optional _beg _end _len)
   (when (overlayp ghc-type-overlay)
     (ghc-type-set-ix 0)

elisp/ghc-process.el

@@ -17,7 +17,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defvar ghc-process-running nil)
-(defvar ghc-process-file-mapping nil)
+
+;; TODO: What happens when ghc-mod returns NG? Probably nothing pleasant.
+(defvar ghc-process-waiting-for-ok nil)
 
 (defvar-local ghc-process-process-name nil)
 (defvar-local ghc-process-original-buffer nil)
@@ -53,10 +55,11 @@
 	(setq ghc-process-original-file file)
 	(setq ghc-process-root root)
 	(let ((pro (ghc-get-process cpro name buf root))
-	      (map-cmd (format "map-file %s\n" file)))
-;	       (unmap-cmd (format "unmap-file %s\n" file)))
-	  (when (buffer-modified-p (current-buffer))
-	    (setq ghc-process-file-mapping t)
+	      (map-cmd (format "map-file %s\n" file))
+              (unmap-cmd (format "unmap-file %s\n" file))
+              (do-map-file (buffer-modified-p cbuf)))
+	  (when do-map-file
+	    (setq ghc-process-waiting-for-ok t)
 	    (setq ghc-process-async-after-callback nil)
 	    (erase-buffer)
 	    (when ghc-debug
@@ -71,27 +74,38 @@
 	    (process-send-string pro "\n\004\n")
 	    (condition-case nil
 		(let ((inhibit-quit nil))
-		  (while ghc-process-file-mapping
+		  (while ghc-process-waiting-for-ok
 		    (accept-process-output pro 0.1 nil t)))
 	      (quit
 	       (setq ghc-process-running nil)
-	       (setq ghc-process-file-mapping nil))))
+	       (setq ghc-process-waiting-for-ok nil))))
 	  ;; command
-	  (setq ghc-process-async-after-callback async-after-callback)
+	  (setq ghc-process-async-after-callback
+                (if do-map-file
+                    ;; TODO: probably racy. What happens when ghc-with-process
+                    ;; is called again before the unmap wait loop below
+                    ;; completes?
+                    (lambda (status)
+                      (if (functionp async-after-callback)
+                          (funcall async-after-callback status))
+                      (when ghc-debug
+                        (ghc-with-debug-buffer
+                         (insert (format "%% %s" unmap-cmd))))
+                      (process-send-string pro unmap-cmd)
+                      (condition-case nil
+                          (let ((inhibit-quit nil))
+                            (while ghc-process-waiting-for-ok
+                              (accept-process-output pro 0.1 nil t)))
+                        (quit
+                         (setq ghc-process-running nil)
+                         (setq ghc-process-waiting-for-ok nil))))
+                  ;; else
+                  async-after-callback))
 	  (erase-buffer)
 	  (when ghc-debug
 	    (ghc-with-debug-buffer
 	     (insert (format "%% %s" cmd))))
 	  (process-send-string pro cmd)
-
-	  ;;; this needs to be done asyncrounously after the command actually
-	  ;;; finished, gah
-	  ;; (when do-map-file
-	  ;;   (when ghc-debug
-	  ;;	 (ghc-with-debug-buffer
-	  ;;	  (insert (format "%% %s" unmap-cmd))))
-	  ;;   (process-send-string pro unmap-cmd))
-
 	  pro)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -169,21 +183,29 @@
 		(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 (status)
+	        (condition-case err
+		    (progn
+		      (funcall ghc-process-async-after-callback status)
+		      (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-waiting-for-ok nil)
+	    (when ghc-process-async-after-callback
+	      (goto-char (point-min))
+	      (async-after-callback 'ok)
+	      ))
+	   ((looking-at "^NG ")
+	    (async-after-callback 'ng))))))))
 
 (defun ghc-process-sentinel (_process _event)
   (setq ghc-process-running nil)
-  (setq ghc-process-file-mapping nil))
+  (setq ghc-process-waiting-for-ok nil))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -230,6 +252,7 @@
       (if (not cpro)
 	  (message "No ghc-mod process")
 	(delete-process cpro)
-	(message "ghc-mod process was killed")))))
+	(message "ghc-mod process was killed")))
+    (setq mode-line-process nil)))
 
 (provide 'ghc-process)