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

making ghc-mod-running a global var (##255).

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-05-14 05:25:37 +09:00
parent 7af19f5400
commit 7d81a357f7
1 changed files with 54 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
elisp/ghc-process.el
View File

@ -12,7 +12,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar-local ghc-process-running nil) (defvar ghc-process-running nil)
(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)
@ -29,7 +30,8 @@
(defun ghc-with-process (cmd callback &optional hook1 hook2) (defun ghc-with-process (cmd callback &optional hook1 hook2)
(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 ghc-process-process-name (when (and ghc-process-process-name (not ghc-process-running))
(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)
@ -37,19 +39,17 @@
(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
(unless ghc-process-running (setq ghc-process-original-buffer cbuf)
(setq ghc-process-running t) (setq ghc-process-original-file file)
(setq ghc-process-original-buffer cbuf) (setq ghc-process-callback callback)
(setq ghc-process-original-file file) (setq ghc-process-hook hook2)
(setq ghc-process-callback callback) (erase-buffer)
(setq ghc-process-hook hook2) (let ((pro (ghc-get-process cpro name buf)))
(erase-buffer) (process-send-string pro cmd)
(let ((pro (ghc-get-process cpro name buf))) (when ghc-debug
(process-send-string pro cmd) (ghc-with-debug-buffer
(when ghc-debug (insert (format "%% %s" cmd))))
(ghc-with-debug-buffer pro)))))
(insert (format "%% %s" cmd))))
pro))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -69,27 +69,30 @@
pro)) pro))
(defun ghc-process-filter (process string) (defun ghc-process-filter (process string)
(ghc-with-current-buffer (process-buffer process) (let ((pbuf (process-buffer process)))
(goto-char (point-max)) (if (not (get-buffer pbuf))
(insert string) (setq ghc-process-running nil) ;; just in case
(forward-line -1) (ghc-with-current-buffer (process-buffer process)
(cond (goto-char (point-max))
((looking-at "^OK$") (insert string)
(if ghc-process-hook (funcall ghc-process-hook)) (forward-line -1)
(goto-char (point-min)) (cond
(funcall ghc-process-callback 'ok) ((looking-at "^OK$")
(when ghc-debug (if ghc-process-hook (funcall ghc-process-hook))
(let ((cbuf (current-buffer))) (goto-char (point-min))
(ghc-with-debug-buffer (funcall ghc-process-callback 'ok)
(insert-buffer-substring cbuf)))) (when ghc-debug
(setq ghc-process-running nil)) (let ((cbuf (current-buffer)))
((looking-at "^NG ") (ghc-with-debug-buffer
(funcall ghc-process-callback 'ng) (insert-buffer-substring cbuf))))
(when ghc-debug (setq ghc-process-running nil))
(let ((cbuf (current-buffer))) ((looking-at "^NG ")
(ghc-with-debug-buffer (funcall ghc-process-callback 'ng)
(insert-buffer-substring cbuf)))) (when ghc-debug
(setq ghc-process-running nil))))) (let ((cbuf (current-buffer)))
(ghc-with-debug-buffer
(insert-buffer-substring cbuf))))
(setq ghc-process-running nil)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -98,21 +101,21 @@
(defvar ghc-process-results nil) (defvar ghc-process-results nil)
(defun ghc-sync-process (cmd &optional n hook) (defun ghc-sync-process (cmd &optional n hook)
(setq ghc-process-rendezvous nil) (unless ghc-process-running
(setq ghc-process-results nil) (setq ghc-process-rendezvous nil)
(setq ghc-process-num-of-results (or n 1)) (setq ghc-process-results nil)
(let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook))) (setq ghc-process-num-of-results (or n 1))
(condition-case nil (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook)))
(while (null ghc-process-rendezvous) (condition-case nil
;; 0.01 is too fast for Emacs 24.4. (while (null ghc-process-rendezvous)
;; (sit-for 0.1 t) may get stuck when tooltip is displayed. ;; 0.01 is too fast for Emacs 24.4.
(sit-for 0.1) ;; (sit-for 0.1 t) may get stuck when tooltip is displayed.
;; (discard-input) avoids getting stuck. (sit-for 0.1)
(discard-input)) ;; (discard-input) avoids getting stuck.
(quit (discard-input))
(ghc-with-current-buffer (process-buffer pro) (quit
(setq ghc-process-running nil))))) (setq ghc-process-running nil))))
ghc-process-results) ghc-process-results))
(defun ghc-process-callback (status) (defun ghc-process-callback (status)
(cond (cond