hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

using ghc-get-project-root only when it is necessary.

Browse Source
This commit is contained in:
Kazu Yamamoto 2015-09-14 15:02:34 +09:00
parent 935c51eb1c
commit 52016b6210
1 changed files with 47 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
elisp/ghc-process.el
View File

@ -35,53 +35,53 @@
(ghc-run-ghc-mod '("root"))) (ghc-run-ghc-mod '("root")))
(defun ghc-with-process (cmd callback &optional hook1 hook2) (defun ghc-with-process (cmd callback &optional hook1 hook2)
(let ((root (ghc-get-project-root))) (unless ghc-process-process-name
(unless ghc-process-process-name (setq ghc-process-process-name (ghc-get-project-root)))
(setq ghc-process-process-name 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 hook1 (funcall hook1)) (let* ((cbuf (current-buffer))
(let* ((cbuf (current-buffer)) (name ghc-process-process-name)
(name ghc-process-process-name) (root ghc-process-process-name)
(buf (get-buffer-create (concat " ghc-mod:" name))) (buf (get-buffer-create (concat " ghc-mod:" name)))
(file (buffer-file-name)) (file (buffer-file-name))
(cpro (get-process name))) (cpro (get-process name)))
(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-hook hook2)
(setq ghc-process-root root) (setq ghc-process-root root)
(let ((pro (ghc-get-process cpro name buf)) (let ((pro (ghc-get-process cpro name buf))
(map-cmd (format "map-file %s\n" file))) (map-cmd (format "map-file %s\n" file)))
;; map-file ;; map-file
(setq ghc-process-file-mapping t) (setq ghc-process-file-mapping t)
(setq ghc-process-callback nil) (setq ghc-process-callback nil)
(erase-buffer) (erase-buffer)
(when ghc-debug (when ghc-debug
(ghc-with-debug-buffer (ghc-with-debug-buffer
(insert (format "%% %s" map-cmd)) (insert (format "%% %s" map-cmd))
(insert "CONTENTS + EOT\n"))) (insert "CONTENTS + EOT\n")))
(process-send-string pro map-cmd) (process-send-string pro map-cmd)
(with-current-buffer cbuf (with-current-buffer cbuf
(save-restriction (save-restriction
(widen) (widen)
(process-send-region pro (point-min) (point-max)))) (process-send-region pro (point-min) (point-max))))
(process-send-string pro "\004\n") (process-send-string pro "\004\n")
(condition-case nil (condition-case nil
(let ((inhibit-quit nil)) (let ((inhibit-quit nil))
(while ghc-process-file-mapping (while ghc-process-file-mapping
(accept-process-output pro 0.1 nil t))) (accept-process-output pro 0.1 nil t)))
(quit (quit
(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-callback 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)
pro)))))) pro)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;