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

supporting map-file in Emacs frontend.

Browse Source
This commit is contained in:
Kazu Yamamoto 2015-08-20 11:33:55 +09:00
parent f0a98cf64f
commit 26d72b0b88
1 changed files with 38 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
elisp/ghc-process.el
View File

@ -16,6 +16,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar ghc-process-running nil) (defvar ghc-process-running nil)
(defvar ghc-process-file-mapping 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)
@ -48,15 +49,38 @@
(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-callback callback)
(setq ghc-process-hook hook2) (setq ghc-process-hook hook2)
(setq ghc-process-root root) (setq ghc-process-root root)
(erase-buffer) (let ((pro (ghc-get-process cpro name buf))
(let ((pro (ghc-get-process cpro name buf))) (map-cmd (format "map-file %s\n" file)))
(process-send-string pro cmd) ;; map-file
(setq ghc-process-file-mapping t)
(setq ghc-process-callback nil)
(erase-buffer)
(when ghc-debug
(ghc-with-debug-buffer
(insert (format "%% %s" map-cmd))
(insert "CONTENTS + EOT\n")))
(process-send-string pro map-cmd)
(with-current-buffer cbuf
(save-restriction
(widen)
(process-send-region pro (point-min) (point-max))))
(process-send-string pro "\004\n")
(condition-case nil
(let ((inhibit-quit nil))
(while ghc-process-file-mapping
(accept-process-output pro 0.1 nil t)))
(quit
(setq ghc-process-running nil)
(setq ghc-process-file-mapping nil)))
;; command
(setq ghc-process-callback callback)
(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)
pro)))))) pro))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -71,11 +95,12 @@
(t cpro))) (t cpro)))
(defun ghc-start-process (name buf) (defun ghc-start-process (name buf)
(let* ((opts (append ghc-debug-options (let* ((process-connection-type nil) ;; using PIPE due to ^D
(opts (append ghc-debug-options
'("-b" "\n" "-l" "--line-prefix=O: ,E: ") '("-b" "\n" "-l" "--line-prefix=O: ,E: ")
(ghc-make-ghc-options) (ghc-make-ghc-options)
'("legacy-interactive"))) '("legacy-interactive")))
(pro (apply 'start-file-process name buf ghc-command opts))) (pro (apply 'start-process name buf ghc-command opts)))
(set-process-filter pro 'ghc-process-filter) (set-process-filter pro 'ghc-process-filter)
(set-process-sentinel pro 'ghc-process-sentinel) (set-process-sentinel pro 'ghc-process-sentinel)
(set-process-query-on-exit-flag pro nil) (set-process-query-on-exit-flag pro nil)
@ -133,10 +158,13 @@
(forward-line -1) (forward-line -1)
(cond (cond
((looking-at "^OK$") ((looking-at "^OK$")
(if ghc-process-hook (funcall ghc-process-hook)) (delete-region (point) (point-max))
(goto-char (point-min)) (setq ghc-process-file-mapping nil)
(funcall ghc-process-callback 'ok) (when ghc-process-callback
(setq ghc-process-running nil)) (if ghc-process-hook (funcall ghc-process-hook))
(goto-char (point-min))
(funcall ghc-process-callback 'ok)
(setq ghc-process-running nil)))
((looking-at "^NG ") ((looking-at "^NG ")
(funcall ghc-process-callback 'ng) (funcall ghc-process-callback 'ng)
(setq ghc-process-running nil))))))) (setq ghc-process-running nil)))))))