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