From e7a186a1035a0b204360698229f974282c5388e2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Fri, 4 Dec 2015 01:33:41 +0100
Subject: [PATCH] elisp: Fix excessive use of map-file

We still don't do unmap-file but this should alleviate the problem
somewhat since most commands won't actually use map-file.
---
 elisp/ghc-comp.el    |  2 +-
 elisp/ghc-info.el    |  8 +-------
 elisp/ghc-process.el | 38 ++++++++++++++++++++++----------------
 3 files changed, 24 insertions(+), 24 deletions(-)

diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el
index 700e8e3..20be9a1 100644
--- a/elisp/ghc-comp.el
+++ b/elisp/ghc-comp.el
@@ -101,7 +101,7 @@ unloaded modules are loaded")
 (defun ghc-boot (n)
   (prog2
       (message "Initializing...")
-      (ghc-sync-process "boot\n" n nil 'skip-map-file)
+      (ghc-sync-process "boot\n" n)
     (message "Initializing...done")))
 
 (defun ghc-load-modules (mods)
diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el
index abe4356..c10e032 100644
--- a/elisp/ghc-info.el
+++ b/elisp/ghc-info.el
@@ -111,13 +111,7 @@
 	 (cn (int-to-string (1+ (current-column))))
 	 (file (buffer-file-name))
 	 (cmd (format "type %s %s %s\n" file ln cn)))
-    (ghc-sync-process cmd nil 'ghc-type-fix-string)))
-
-(defun ghc-type-fix-string ()
-  (save-excursion
-    (goto-char (point-min))
-    (while (search-forward "[Char]" nil t)
-      (replace-match "String"))))
+    (ghc-sync-process cmd nil)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el
index 2a70b27..257a18e 100644
--- a/elisp/ghc-process.el
+++ b/elisp/ghc-process.el
@@ -1,3 +1,4 @@
+;;; -*- lexical-binding: t -*-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; ghc-process.el
@@ -21,8 +22,6 @@
 (defvar-local ghc-process-process-name nil)
 (defvar-local ghc-process-original-buffer nil)
 (defvar-local ghc-process-original-file nil)
-(defvar-local ghc-process-callback nil)
-(defvar-local ghc-process-hook nil)
 (defvar-local ghc-process-root nil)
 
 (defvar ghc-command "ghc-mod")
@@ -35,12 +34,12 @@
 (defun ghc-get-project-root ()
   (ghc-run-ghc-mod '("root")))
 
-(defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file)
+(defun ghc-with-process (cmd async-after-callback &optional sync-before-hook)
   (unless ghc-process-process-name
     (setq ghc-process-process-name (ghc-get-project-root)))
   (when (and ghc-process-process-name (not ghc-process-running))
     (setq ghc-process-running t)
-    (if hook1 (funcall hook1))
+    (if sync-before-hook (funcall sync-before-hook))
     (let* ((cbuf (current-buffer))
 	   (name ghc-process-process-name)
 	   (root (file-name-as-directory ghc-process-process-name))
@@ -52,14 +51,13 @@
       (ghc-with-current-buffer buf
         (setq ghc-process-original-buffer cbuf)
 	(setq ghc-process-original-file file)
-	(setq ghc-process-hook hook2)
 	(setq ghc-process-root root)
 	(let ((pro (ghc-get-process cpro name buf root))
 	      (map-cmd (format "map-file %s\n" file)))
-	  ;; map-file
-	  (unless skip-map-file
+;	       (unmap-cmd (format "unmap-file %s\n" file)))
+	  (when (buffer-modified-p (current-buffer))
 	    (setq ghc-process-file-mapping t)
-	    (setq ghc-process-callback nil)
+	    (setq ghc-process-async-after-callback nil)
 	    (erase-buffer)
 	    (when ghc-debug
 	      (ghc-with-debug-buffer
@@ -79,12 +77,21 @@
 	       (setq ghc-process-running nil)
 	       (setq ghc-process-file-mapping nil))))
 	  ;; command
-	  (setq ghc-process-callback callback)
+	  (setq ghc-process-async-after-callback 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)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -166,13 +173,12 @@
 	 ((looking-at "^OK$")
 	  (delete-region (point) (point-max))
 	  (setq ghc-process-file-mapping nil)
-	  (when ghc-process-callback
-	    (if ghc-process-hook (funcall ghc-process-hook))
+	  (when ghc-process-async-after-callback
 	    (goto-char (point-min))
-	    (funcall ghc-process-callback 'ok)
+	    (funcall ghc-process-async-after-callback 'ok)
 	    (setq ghc-process-running nil)))
 	 ((looking-at "^NG ")
-	  (funcall ghc-process-callback 'ng)
+	  (funcall ghc-process-async-after-callback 'ng)
 	  (setq ghc-process-running nil)))))))
 
 (defun ghc-process-sentinel (_process _event)
@@ -185,12 +191,12 @@
 (defvar ghc-process-num-of-results nil)
 (defvar ghc-process-results nil)
 
-(defun ghc-sync-process (cmd &optional n hook skip-map-file)
+(defun ghc-sync-process (cmd &optional n)
   (unless ghc-process-running
     (setq ghc-process-rendezvous nil)
     (setq ghc-process-results nil)
     (setq ghc-process-num-of-results (or n 1))
-    (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook skip-map-file)))
+    (let ((pro (ghc-with-process cmd 'ghc-sync-process-callback nil)))
       ;; ghc-process-running is now t.
       ;; But if the process exits abnormally, it is set to nil.
       (condition-case nil
@@ -201,7 +207,7 @@
 	 (setq ghc-process-running nil))))
     ghc-process-results))
 
-(defun ghc-process-callback (status)
+(defun ghc-sync-process-callback (status)
   (cond
    ((eq status 'ok)
     (let* ((n ghc-process-num-of-results)