emacs,haskell補完2

前回の続き。ghci上でタブを入力することで現れる候補を利用して補完。
でも、エラーもまるごと読み取って捨てているという強引なことをしているので適切な方法とは言えないような気もする。とりあえず、利用することはできるのでまぁいいや。

code

(require 'anything)

;;;util
(defmacro let1 (var val &rest action)
  `(let ((,var ,val))
     ,@action))
(put 'let1 'lisp-indent-function 2)

(defun define-many-keys (key-map key-table)
  (loop for (key . cmd) in key-table
		do (define-key key-map key cmd)))

(defmacro toggle! (name)
  `(progn (setq ,name (not ,name))
		  (message (format "%s:%s" ,(symbol-name name) ,name))))

(defmacro select/anything (seq &optional name init)
  (let1 source (gensym)
	`(let1 ,source
		 `((name . ,(or ,name "candidate"))
		   (candidates . ,,seq)
		   (action . identity))
	   (anything (list ,source) ,init))))
;;;main

(defun haskell-send-string (str)
  (condition-case err
      (comint-send-string (get-process "haskell") (format "%s\n" str))
    (error err)))

(defvar haskell-preoutput-filter-functions nil)
(defvar haskell-output-storage nil)
(defvar haskell-connect-inistalled nil)

(defun haskell-connect-cleanup ()
  (setq haskell-output-storage nil))

(defmacro haskell-connect-with-repl (send-func)
  `(let ((haskell-reading-p t)
		 (old-filter comint-preoutput-filter-functions)
		 (comint-preoutput-filter-functions haskell-preoutput-filter-functions))
     (unwind-protect
		 (progn
		   (haskell-connect-cleanup)
		   ,send-func
		   (while haskell-reading-p (sleep-for 0 100))
		   (funcall haskell-output-filter
					(apply 'concat (reverse haskell-output-storage))))
       (setq comint-preoutput-filter-functions old-filter))))

(defun haskell-repl-running-p () (get-process "haskell"))

(defmacro haskell-filter-function-maker (regexp)
  (let1 s (gensym)
    `(lambda (,s)
       (when (string-match-p ,regexp ,s)
		 (setq haskell-reading-p nil))
       (push ,s haskell-output-storage)
       "")))

(defvar haskell-connect-ask-y-or-n-messages
  '("Display +all +[0-9]+ +possibilities\\? (y or n)" "--More--"))

(defvar haskell-connect-junk-messages
  `("<interactive>:[0-9]+:[0-9]+: parse error on input.*"
	"<interactive>:[0-9]+:[0-9]+: Not in scope:.*"
	,@haskell-connect-ask-y-or-n-messages))

(defun haskell-connect-install () (interactive)
  (when (and (haskell-repl-running-p)
			 (not haskell-connect-inistalled))
    (haskell-send-string ":set prompt \"REPL> \"")
    (toggle! haskell-connect-inistalled)
    (add-hook 'haskell-preoutput-filter-functions
			  (haskell-filter-function-maker "REPL> *$"))
    (add-hook 'haskell-preoutput-filter-functions
			  (lambda (s)
				(when (some (lambda (regexp) (string-match-p regexp s))
							haskell-connect-ask-y-or-n-messages)
				  (haskell-send-string "y"))
				s))
    (setq haskell-output-filter
		  (lambda (s) (substring-no-properties s 0 -7)))
    ))

(defsubst haskell-dynamic-get-source (init &optional format-arg again-p)
  "補完候補の取得(fo[tab] -> foldの時に対応するために再帰を利用)"
  (let* ((src (haskell-connect-with-repl
			   (haskell-send-string (format format-arg init))))
		 (src*
		  (loop for regexp in haskell-connect-junk-messages
				do (setq src (replace-regexp-in-string regexp "" src))
				finally return (split-string src))))
	(if (and (not again-p) (null src*))
		(haskell-dynamic-get-source init "%s\t\t\t" t)
	  src*)))
  
(defun haskell-dynamic-complete () (interactive)
  (let* ((init (let1 end (point)
				 (buffer-substring-no-properties
				  (progn (skip-syntax-backward "w_") (point)) end)))
		 (src* (haskell-dynamic-get-source init "%s\t\t"))
		 (completed (select/anything src* "function" init)))
	(delete-char (length init))
	(insert completed)))

;; interactive
(defun haskell-complete-prepare () (interactive)
  (unless (haskell-repl-running-p)
	(run-haskell)
	(other-window -1))
  (haskell-connect-install))


(defun haskell-insert-module () (interactive)
  (let1 candidate
	  (select/anything (mapcar 'car (inferior-haskell-module-alist)))
	(insert (format "import %s" candidate))))

;; setting
(defvar haskell-key-table
  '(("\C-cS" . haskell-complete-prepare)
	("\C-c\C-j" . haskell-dynamic-complete)))

(autoload 'run-haskell "inf-haskell")
(add-hook 'haskell-mode-hook
		  (lambda ()
			(define-many-keys haskell-mode-map haskell-key-table)))