From dc6424454e2c52ef1ebce2610b8c30ca470b18a2 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 25 Mar 2014 14:29:18 +0900 Subject: [PATCH] ghc-insert-module now uses ghc-modi. --- elisp/Makefile | 2 +- elisp/ghc-check.el | 106 +++++--------------- elisp/ghc-flymake.el | 233 ------------------------------------------- elisp/ghc-ins-mod.el | 70 +++++++------ elisp/ghc-process.el | 81 +++++++++++++++ ghc-mod.cabal | 2 +- 6 files changed, 148 insertions(+), 346 deletions(-) delete mode 100644 elisp/ghc-flymake.el create mode 100644 elisp/ghc-process.el diff --git a/elisp/Makefile b/elisp/Makefile index caabdba..d77aed3 100644 --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,4 +1,4 @@ -SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el \ +SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \ ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el EMACS = emacs DETECT = xemacs diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index 5e6d96c..506878d 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -13,6 +13,7 @@ ;; * multiple Mains in the same directory (require 'ghc-func) +(require 'ghc-process) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -35,89 +36,36 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar-local ghc-check-running nil) -(defvar-local ghc-check-process-name nil) -(defvar-local ghc-check-original-buffer nil) -(defvar-local ghc-check-original-file nil) +(defun ghc-check-syntax () + (interactive) + (ghc-with-process 'ghc-check-send 'ghc-check-callback)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ghc-defstruct hilit-info file line col msg) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ghc-check-send () + (concat "check " ghc-process-original-file "\n")) -(defun ghc-check-syntax () - (unless ghc-check-process-name - (setq ghc-check-process-name (ghc-check-get-process-name))) - (if (null ghc-check-process-name) - (message "Can't check") - (let* ((cbuf (current-buffer)) - (name ghc-check-process-name) - (buf (get-buffer-create (concat " ghc-modi:" name))) - (file (buffer-file-name)) - (cpro (get-process name))) - (with-current-buffer buf - (unless ghc-check-running - (setq ghc-check-running t) - (setq ghc-check-original-buffer cbuf) - (setq ghc-check-original-file file) - (erase-buffer) - (let ((pro (ghc-check-get-process cpro name buf))) - (process-send-string pro (concat "check " file "\n")))))))) - -(defun ghc-check-get-process-name () - (let ((file (buffer-file-name))) - (with-temp-buffer - (ghc-call-process ghc-module-command nil t nil "root" file) - (goto-char (point-min)) - (when (looking-at "^\\(.*\\)$") - (match-string-no-properties 1))))) - -(defun ghc-check-get-process (cpro name buf) - (cond - ((not cpro) - (ghc-check-start-process name buf)) - ((not (eq (process-status cpro) 'run)) - (delete-process cpro) - (ghc-check-start-process name buf)) - (t cpro))) - -(defun ghc-check-start-process (name buf) - (let ((pro (start-file-process name buf "ghc-modi"))) - (set-process-filter pro 'ghc-check-process-filter) - (set-process-sentinel pro 'ghc-check-process-sentinel) - (set-process-query-on-exit-flag pro nil) - pro)) - -(defun ghc-check-process-filter (process string) - (with-current-buffer (process-buffer process) - (goto-char (point-max)) - (insert string) - (forward-line -1) - (when (looking-at "^\\(OK\\|NG\\)$") - (goto-char (point-min)) - (let ((regex "^\\([^\n\0]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\(.+\\)") - info infos) - (while (re-search-forward regex nil t) - (setq info (ghc-make-hilit-info - :file (match-string 1) - :line (string-to-number (match-string 2)) - :col (string-to-number (match-string 3)) - :msg (match-string 4))) - (setq infos (cons info infos))) - (setq infos (nreverse infos)) - (cond - (infos - (let ((file ghc-check-original-file) - (buf ghc-check-original-buffer)) - (ghc-check-highlight-original-buffer file buf infos))) - (t - (with-current-buffer ghc-check-original-buffer - (remove-overlays (point-min) (point-max) 'ghc-check t)))) - (setq ghc-check-running nil))))) - -(defun ghc-check-process-sentinel (process event) - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ghc-check-callback () + (let ((regex "^\\([^\n\0]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\(.+\\)") + info infos) + (while (re-search-forward regex nil t) + (setq info (ghc-make-hilit-info + :file (match-string 1) + :line (string-to-number (match-string 2)) + :col (string-to-number (match-string 3)) + :msg (match-string 4))) + (setq infos (cons info infos))) + (setq infos (nreverse infos)) + (cond + (infos + (let ((file ghc-process-original-file) + (buf ghc-process-original-buffer)) + (ghc-check-highlight-original-buffer file buf infos))) + (t + (with-current-buffer ghc-process-original-buffer + (remove-overlays (point-min) (point-max) 'ghc-check t)))))) (defun ghc-check-highlight-original-buffer (ofile buf infos) (with-current-buffer buf diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el deleted file mode 100644 index 53b57c2..0000000 --- a/elisp/ghc-flymake.el +++ /dev/null @@ -1,233 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; ghc-flymake.el -;;; - -;; Author: Kazu Yamamoto -;; Created: Mar 12, 2010 - -;;; Code: - -(require 'flymake) -(require 'ghc-func) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar ghc-hlint-options nil "*Hlint options") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst ghc-flymake-allowed-file-name-masks - '("\\.l?hs$" ghc-flymake-init nil ghc-emacs23-later-hack)) - -(defconst ghc-flymake-err-line-patterns - '("^\\(.*\\):\\([0-9]+\\):\\([0-9]+\\):[ ]*\\(.+\\)" 1 2 3 4)) - -(add-to-list 'flymake-allowed-file-name-masks - ghc-flymake-allowed-file-name-masks) - -(add-to-list 'flymake-err-line-patterns - ghc-flymake-err-line-patterns) - -;; flymake of Emacs 23 or later does not display errors -;; if they occurred in other files. So, let's cheat flymake. -(defun ghc-emacs23-later-hack (tmp-file) - (let ((real-name (flymake-get-real-file-name tmp-file)) - (hack-name (flymake-get-real-file-name buffer-file-name))) - (unless (string= real-name hack-name) - ;; Change the local variable, line-err-info, - ;; in flymake-parse-err-lines. - (when (boundp 'line-err-info) - (setq line-err-info - (flymake-ler-make-ler - nil - 1 - (flymake-ler-type line-err-info) - (concat real-name ": " (flymake-ler-text line-err-info)) - (flymake-ler-full-file line-err-info))))) - hack-name)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun ghc-flymake-init () - (list ghc-module-command (ghc-flymake-command (flymake-init-create-temp-buffer-copy 'flymake-create-temp-inplace)))) - -(defvar ghc-flymake-command nil) ;; nil: check, t: lint - -(defun ghc-flymake-command (file) - (if ghc-flymake-command - (let ((hopts (ghc-mapconcat (lambda (x) (list "-h" x)) ghc-hlint-options))) - `(,@hopts "lint" ,file)) - `(,@(ghc-make-ghc-options) "check" ,file))) - -(defun ghc-flymake-toggle-command () - (interactive) - (setq ghc-flymake-command (not ghc-flymake-command)) - (if ghc-flymake-command - (message "Syntax check with hlint") - (message "Syntax check with GHC"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun ghc-flymake-display-errors () - (interactive) - (if (not (ghc-flymake-have-errs-p)) - (message "No errors or warnings") - (let ((title (ghc-flymake-err-title)) - (errs (ghc-flymake-err-list))) - (ghc-display - nil - (lambda () - (insert title "\n\n") - (mapc (lambda (x) (insert x "\n")) errs)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun ghc-flymake-jump () - (interactive) - (if (not (ghc-flymake-have-errs-p)) - (message "No errors or warnings") - (let* ((acts (ghc-flymake-act-list)) - (act (car acts))) - (if (not act) - (message "No destination") - (eval act))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun ghc-extract-type (str) - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (when (re-search-forward "Inferred type: \\|no type signature:\\( \\|\0 +\\)?" nil t) - (delete-region (point-min) (point))) - (when (re-search-forward " forall [^.]+\\." nil t) - (replace-match "")) - (while (re-search-forward "\0 +" nil t) - (replace-match " ")) - (goto-char (point-min)) - (while (re-search-forward "\\[Char\\]" nil t) - (replace-match "String")) - (re-search-forward "\0" nil t) - (buffer-substring-no-properties (point-min) (1- (point))))) - -(defun ghc-flymake-insert-from-warning () - (interactive) - (dolist (data (ghc-flymake-err-list)) - (save-excursion - (cond - ((string-match "Inferred type: \\|no type signature:" data) - (beginning-of-line) - (insert (ghc-extract-type data) "\n")) - ((string-match "lacks an accompanying binding" data) - (beginning-of-line) - (when (looking-at "^\\([^ ]+\\) *::") - (save-match-data - (forward-line) - (if (not (bolp)) (insert "\n"))) - (insert (match-string 1) " = undefined\n"))) - ((string-match "Not in scope: `\\([^']+\\)'" data) - (save-match-data - (unless (re-search-forward "^$" nil t) - (goto-char (point-max)) - (insert "\n"))) - (insert "\n" (match-string 1 data) " = undefined\n")) - ((string-match "Pattern match(es) are non-exhaustive" data) - (let* ((fn (ghc-get-function-name)) - (arity (ghc-get-function-arity fn))) - (ghc-insert-underscore fn arity))) - ((string-match "Found:\0[ ]*\\([^\0]+\\)\0Why not:\0[ ]*\\([^\0]+\\)" data) - (let ((old (match-string 1 data)) - (new (match-string 2 data))) - (beginning-of-line) - (when (search-forward old nil t) - (let ((end (point))) - (search-backward old nil t) - (delete-region (point) end)) - (insert new)))))))) - -(defun ghc-get-function-name () - (save-excursion - (beginning-of-line) - (when (looking-at "\\([^ ]+\\) ") - (match-string 1)))) - -(defun ghc-get-function-arity (fn) - (when fn - (save-excursion - (let ((regex (format "^%s *::" (regexp-quote fn)))) - (when (re-search-backward regex nil t) - (ghc-get-function-arity0)))))) - -(defun ghc-get-function-arity0 () - (let ((end (save-excursion (end-of-line) (point))) - (arity 0)) - (while (search-forward "->" end t) - (setq arity (1+ arity))) - arity)) - -(defun ghc-insert-underscore (fn ar) - (when fn - (let ((arity (or ar 1))) - (save-excursion - (goto-char (point-max)) - (re-search-backward (format "^%s *::" (regexp-quote fn))) - (forward-line) - (re-search-forward "^$" nil t) - (insert fn) - (dotimes (i arity) - (insert " _")) - (insert " = error \"" fn "\""))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun ghc-flymake-err-get-title (x) (nth 0 x)) -(defun ghc-flymake-err-get-errs (x) (nth 1 x)) - -(defun ghc-flymake-err-get-err-msg (x) (nth 0 x)) -(defun ghc-flymake-err-get-err-act (x) (nth 1 x)) - -(defalias 'ghc-flymake-have-errs-p 'ghc-flymake-data) - -(defun ghc-flymake-data () - (let* ((line-no (line-number-at-pos)) - (info (nth 0 (flymake-find-err-info flymake-err-info line-no)))) - (flymake-make-err-menu-data-stolen line-no info))) - -(defun flymake-make-err-menu-data-stolen (line-no line-err-info-list) - "Make a (menu-title (item-title item-action)*) list with errors/warnings from LINE-ERR-INFO-LIST." - (let* ((menu-items nil)) - (when line-err-info-list - (let* ((count (length line-err-info-list)) - (menu-item-text nil)) - (while (> count 0) - (setq menu-item-text (flymake-ler-text (nth (1- count) line-err-info-list))) - (let* ((file (flymake-ler-file (nth (1- count) line-err-info-list))) - (full-file (flymake-ler-full-file (nth (1- count) line-err-info-list))) - (line (flymake-ler-line (nth (1- count) line-err-info-list)))) - (if file - (setq menu-item-text (concat menu-item-text " - " file "(" (format "%d" line) ")"))) - (setq menu-items (cons (list menu-item-text - (if file (list 'flymake-goto-file-and-line full-file line) nil)) - menu-items))) - (setq count (1- count))) - (flymake-log 3 "created menu-items with %d item(s)" (length menu-items)))) - (if menu-items - (let* ((menu-title (format "Line %d: %d error(s), %d warning(s)" line-no - (flymake-get-line-err-count line-err-info-list "e") - (flymake-get-line-err-count line-err-info-list "w")))) - (list menu-title menu-items)) - nil))) - -(defun ghc-flymake-err-title () - (ghc-flymake-err-get-title (ghc-flymake-data))) - -(defun ghc-flymake-err-list () - (mapcar 'ghc-flymake-err-get-err-msg (ghc-flymake-err-get-errs (ghc-flymake-data)))) - -(defun ghc-flymake-act-list () - (mapcar 'ghc-flymake-err-get-err-act (ghc-flymake-err-get-errs (ghc-flymake-data)))) - -(provide 'ghc-flymake) diff --git a/elisp/ghc-ins-mod.el b/elisp/ghc-ins-mod.el index 3c305ad..aef921f 100644 --- a/elisp/ghc-ins-mod.el +++ b/elisp/ghc-ins-mod.el @@ -8,23 +8,27 @@ ;;; Code: -(defvar ghc-hoogle-command "hoogle") +(defvar ghc-ins-mod-rendezvous nil) (defun ghc-insert-module () (interactive) - (ghc-executable-find ghc-hoogle-command - (let* ((expr0 (ghc-things-at-point)) - (expr (ghc-read-expression expr0))) - (let ((mods (ghc-function-to-modules expr))) - (if (null mods) - (message "No module guessed") - (let* ((first (car mods)) - (mod (if (= (length mods) 1) - first - (completing-read "Module name: " mods nil t first)))) - (save-excursion - (ghc-goto-module-position) - (insert "import " mod "\n")))))))) + (let* ((expr0 (ghc-things-at-point)) + (expr (ghc-read-expression expr0))) + (let ((mods (ghc-function-to-modules expr))) + (if (null mods) + (message "No module guessed") + (let ((mod (ghc-completing-read "Module name (%s): " mods))) + (save-excursion + (ghc-goto-module-position) + (if (string-match "^[a-zA-Z0-9_]$" expr) + (insert "import " mod " (" expr ")\n") + (insert "import " mod " ((" expr "))\n")))))))) + +(defun ghc-completing-read (fmt lst) + (let* ((def (car lst)) + (prompt (format fmt def)) + (inp (completing-read prompt lst))) + (if (string= inp "") def inp))) (defun ghc-goto-module-position () (goto-char (point-max)) @@ -38,25 +42,27 @@ (unless (re-search-forward "^$" nil t) (forward-line))) -;; To avoid Data.Functor -(defvar ghc-applicative-operators '("<$>" "<$" "<*>" "<**>" "<*" "*>" "<|>")) +(defun ghc-function-to-modules (fun) + (setq ghc-ins-mod-rendezvous nil) + (ghc-with-process + (lambda () (ghc-ins-mod-send fun)) + 'ghc-ins-mod-callback) + (while (null ghc-ins-mod-rendezvous) + (sit-for 0.01)) + ghc-ins-mod-rendezvous) -(defun ghc-function-to-modules (fn) - (if (member fn ghc-applicative-operators) - '("Control.Applicative") - (ghc-function-to-modules-hoogle fn))) +(defun ghc-ins-mod-send (fun) + (concat "find " fun "\n")) -(defun ghc-function-to-modules-hoogle (fn) - (with-temp-buffer - (let* ((fn1 (if (string-match "^[a-zA-Z0-9'_]+$" fn) - fn - (concat "(" fn ")"))) - (regex (concat "^\\([a-zA-Z0-9.]+\\) " fn1 " ")) - ret) - (ghc-call-process ghc-hoogle-command nil t nil "search" fn1) - (goto-char (point-min)) - (while (re-search-forward regex nil t) - (setq ret (cons (match-string 1) ret))) - (nreverse ret)))) +(defun ghc-ins-mod-callback () + (let (lines line beg) + (while (not (eobp)) + (setq beg (point)) + (forward-line) + (setq line (buffer-substring-no-properties beg (1- (point)))) + (setq lines (cons line lines))) + (with-current-buffer ghc-process-original-buffer + (setq ghc-ins-mod-rendezvous + (nreverse (cdr lines)))))) ;; removing "OK" (provide 'ghc-ins-mod) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el new file mode 100644 index 0000000..64cb404 --- /dev/null +++ b/elisp/ghc-process.el @@ -0,0 +1,81 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc-process.el +;;; + +;; Author: Kazu Yamamoto +;; Created: Mar 9, 2014 + +;;; Code: + +(require 'ghc-func) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar-local ghc-process-running nil) +(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 ghc-interactive-command "ghc-modi") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-get-process-name () + (let ((file (buffer-file-name))) + (with-temp-buffer + (ghc-call-process ghc-module-command nil t nil "root" file) + (goto-char (point-min)) + (when (looking-at "^\\(.*\\)$") + (match-string-no-properties 1))))) + +(defun ghc-with-process (send callback) + (unless ghc-process-process-name + (setq ghc-process-process-name (ghc-get-process-name))) + (when ghc-process-process-name + (let* ((cbuf (current-buffer)) + (name ghc-process-process-name) + (buf (get-buffer-create (concat " ghc-modi:" name))) + (file (buffer-file-name)) + (cpro (get-process name))) + (with-current-buffer buf + (unless ghc-process-running + (setq ghc-process-running t) + (setq ghc-process-original-buffer cbuf) + (setq ghc-process-original-file file) + (setq ghc-process-callback callback) + (erase-buffer) + (let ((pro (ghc-get-process cpro name buf))) + (process-send-string pro (funcall send)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-get-process (cpro name buf) + (cond + ((not cpro) + (ghc-start-process name buf)) + ((not (eq (process-status cpro) 'run)) + (delete-process cpro) + (ghc-start-process name buf)) + (t cpro))) + +(defun ghc-start-process (name buf) + (let ((pro (start-file-process name buf ghc-interactive-command))) + (set-process-filter pro 'ghc-process-filter) + (set-process-query-on-exit-flag pro nil) + pro)) + +(defun ghc-process-filter (process string) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string) + (forward-line -1) + (when (looking-at "^\\(OK\\|NG\\)$") + (goto-char (point-min)) + (funcall ghc-process-callback) + (setq ghc-process-running nil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'ghc-process) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index c37d1aa..180c511 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -21,7 +21,7 @@ Cabal-Version: >= 1.10 Build-Type: Simple Data-Dir: elisp Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el - ghc-flymake.el ghc-command.el ghc-info.el + ghc-check.el ghc-process.el ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-pkg.el Extra-Source-Files: ChangeLog test/data/*.cabal