ghc-mod/elisp/ghc-process.el

226 lines
6.8 KiB
EmacsLisp
Raw Normal View History

2014-03-25 05:29:18 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc-process.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; Created: Mar 9, 2014
;;; Code:
(require 'ghc-func)
2015-08-14 07:47:44 +00:00
(defvar ghc-debug-options nil)
;; (setq ghc-debug-options '("-v9"))
2014-03-25 05:29:18 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar ghc-process-running nil)
2015-08-20 02:33:55 +00:00
(defvar ghc-process-file-mapping nil)
2014-03-25 05:29:18 +00:00
(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)
2014-03-25 05:29:18 +00:00
2015-08-14 02:36:37 +00:00
(defvar ghc-command "ghc-mod")
2015-08-13 07:50:19 +00:00
(defvar ghc-error-buffer "*GHC Error*")
2014-03-25 05:29:18 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2014-03-25 06:23:08 +00:00
(defun ghc-get-project-root ()
2014-04-21 02:37:33 +00:00
(ghc-run-ghc-mod '("root")))
2014-03-25 05:29:18 +00:00
2015-09-14 06:09:34 +00:00
(defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file)
(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))
(let* ((cbuf (current-buffer))
(name ghc-process-process-name)
(root (file-name-as-directory ghc-process-process-name))
(buf (get-buffer-create (concat " ghc-mod:" name)))
(file (buffer-file-name))
(cpro (get-process name)))
(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
2015-09-14 06:09:34 +00:00
(unless skip-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
(ghc-with-debug-buffer
(insert (format "%% %s" cmd))))
(process-send-string pro cmd)
pro)))))
2014-03-25 05:29:18 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ghc-get-process (cpro name buf root)
(cond
((not cpro)
(ghc-start-process name buf root))
((not (eq (process-status cpro) 'run))
(delete-process cpro)
(ghc-start-process name buf root))
(t cpro)))
(defun ghc-start-process (name buf root)
(let* ((default-directory root)
(process-connection-type nil) ;; using PIPE due to ^D
2015-08-20 02:33:55 +00:00
(opts (append ghc-debug-options
2015-08-14 07:47:44 +00:00
'("-b" "\n" "-l" "--line-prefix=O: ,E: ")
2015-08-14 02:36:37 +00:00
(ghc-make-ghc-options)
'("legacy-interactive")))
2015-08-20 02:33:55 +00:00
(pro (apply 'start-process name buf ghc-command opts)))
2014-03-25 05:29:18 +00:00
(set-process-filter pro 'ghc-process-filter)
2014-05-13 21:39:50 +00:00
(set-process-sentinel pro 'ghc-process-sentinel)
2014-03-25 05:29:18 +00:00
(set-process-query-on-exit-flag pro nil)
pro))
(defun ghc-process-filter (process string)
2015-08-13 07:50:19 +00:00
(let* ((pbuf (process-buffer process))
(tbufname (concat " tmp " (buffer-name pbuf)))
tbuf)
(if (not (get-buffer pbuf))
(setq ghc-process-running nil) ;; just in case
2015-08-13 07:50:19 +00:00
(ghc-with-current-buffer pbuf
2015-08-13 05:40:48 +00:00
(when ghc-debug
(ghc-with-debug-buffer
(insert string)))
2015-08-13 07:50:19 +00:00
(with-current-buffer (get-buffer-create tbufname)
(setq tbuf (current-buffer))
(goto-char (point-max))
(insert string)
(goto-char (point-min))
(let ((cont t) end out)
2015-09-14 04:07:51 +00:00
(while (and cont (not (eobp)) ghc-process-running)
2015-08-13 07:50:19 +00:00
(cond
((looking-at "^O: ")
(setq out t))
((looking-at "^E: ")
(setq out nil))
(t
(setq cont nil)))
(when cont
(forward-line)
(unless (bolp) (setq cont nil)))
(when cont
(delete-region 1 4)
(setq end (point))
(if out
(with-current-buffer pbuf
(goto-char (point-max))
(insert-buffer-substring tbuf 1 end))
(with-current-buffer (get-buffer-create ghc-error-buffer)
2015-08-14 02:40:57 +00:00
(setq buffer-read-only t)
(let* ((buffer-read-only nil)
(inhibit-read-only t)
(cbuf (current-buffer))
2015-08-13 08:39:01 +00:00
cwin)
(unless (get-buffer-window cbuf) (display-buffer cbuf))
(setq cwin (get-buffer-window cbuf))
2015-08-14 05:21:07 +00:00
(with-selected-window cwin
(goto-char (point-max))
(insert-buffer-substring tbuf 1 end)
(set-buffer-modified-p nil))
(redisplay))))
2015-08-13 07:50:19 +00:00
(delete-region 1 end)))))
(goto-char (point-max))
(forward-line -1)
(cond
((looking-at "^OK$")
2015-08-20 02:33:55 +00:00
(delete-region (point) (point-max))
(setq ghc-process-file-mapping nil)
(when ghc-process-callback
(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 ")
(funcall ghc-process-callback 'ng)
(setq ghc-process-running nil)))))))
2014-03-25 05:29:18 +00:00
2015-08-19 06:37:41 +00:00
(defun ghc-process-sentinel (_process _event)
2015-09-14 04:07:51 +00:00
(setq ghc-process-running nil)
(setq ghc-process-file-mapping nil))
2014-05-13 21:39:50 +00:00
2014-03-25 05:29:18 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2014-04-19 11:48:26 +00:00
(defvar ghc-process-rendezvous nil)
(defvar ghc-process-num-of-results nil)
2014-04-19 11:48:26 +00:00
(defvar ghc-process-results nil)
2015-09-14 06:09:34 +00:00
(defun ghc-sync-process (cmd &optional n hook skip-map-file)
(unless ghc-process-running
(setq ghc-process-rendezvous nil)
(setq ghc-process-results nil)
(setq ghc-process-num-of-results (or n 1))
2015-09-14 06:09:34 +00:00
(let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook skip-map-file)))
2014-12-01 02:44:39 +00:00
;; ghc-process-running is now t.
;; But if the process exits abnormally, it is set to nil.
(condition-case nil
(let ((inhibit-quit nil))
2014-12-01 02:44:39 +00:00
(while (and (null ghc-process-rendezvous) ghc-process-running)
2014-11-29 03:57:23 +00:00
(accept-process-output pro 0.1 nil t)))
(quit
(setq ghc-process-running nil))))
ghc-process-results))
2014-04-19 11:48:26 +00:00
2014-04-27 12:51:44 +00:00
(defun ghc-process-callback (status)
(cond
((eq status 'ok)
(let* ((n ghc-process-num-of-results)
(ret (if (= n 1)
(ghc-read-lisp-this-buffer)
(ghc-read-lisp-list-this-buffer n))))
(setq ghc-process-results ret)))
(t
(setq ghc-process-results nil)))
(setq ghc-process-num-of-results nil)
(setq ghc-process-rendezvous t))
2014-04-19 11:48:26 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2014-03-30 02:54:17 +00:00
(defun ghc-kill-process ()
(interactive)
(when (eq major-mode 'haskell-mode)
(let* ((name ghc-process-process-name)
(cpro (if name (get-process name))))
(if (not cpro)
(message "No ghc-mod process")
(delete-process cpro)
(message "ghc-mod process was killed")))))
2014-03-30 02:54:17 +00:00
2014-03-25 05:29:18 +00:00
(provide 'ghc-process)