ghc-mod/elisp/ghc-info.el
2012-02-13 13:23:04 +09:00

142 lines
3.8 KiB
EmacsLisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc-info.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; Created: Nov 15, 2010
;;; Code:
(require 'ghc-func)
(defun ghc-show-info (&optional ask)
(interactive "P")
(if (not (ghc-which ghc-module-command))
(message "%s not found" ghc-module-command)
(let ((modname (ghc-find-module-name)))
(if (not modname)
(message "module should be specified")
(ghc-show-info0 ask modname)))))
(defun ghc-show-info0 (ask modname)
(let* ((expr0 (ghc-things-at-point))
(expr (if ask (ghc-read-expression expr0) expr0))
(cdir default-directory)
(file (buffer-name))
(buf (get-buffer-create ghc-error-buffer-name)))
(with-current-buffer buf
(erase-buffer)
(insert
(with-temp-buffer
(cd cdir)
(apply 'call-process ghc-module-command nil t nil
`(,@(ghc-make-ghc-options) "info" ,file ,modname ,expr))
(buffer-substring (point-min) (1- (point-max))))))
(display-buffer buf)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; type
;;;
(defvar ghc-type-overlay nil)
(make-variable-buffer-local 'ghc-type-overlay)
(defun ghc-type-set-ix (n)
(overlay-put ghc-type-overlay 'ix n))
(defun ghc-type-get-ix ()
(overlay-get ghc-type-overlay 'ix))
(defun ghc-type-set-point (pos)
(overlay-put ghc-type-overlay 'pos pos))
(defun ghc-type-get-point ()
(overlay-get ghc-type-overlay 'pos))
(defun ghc-type-set-types (types)
(overlay-put ghc-type-overlay 'types types))
(defun ghc-type-get-types ()
(overlay-get ghc-type-overlay 'types))
(defun ghc-type-init ()
(setq ghc-type-overlay (make-overlay 0 0))
(overlay-put ghc-type-overlay 'face 'region)
(ghc-type-set-ix 0)
(ghc-type-set-point 0)
(setq after-change-functions
(cons 'ghc-delete-type-ovl after-change-functions)))
(defun ghc-delete-type-ovl (beg end len)
(when (overlayp ghc-type-overlay)
(delete-overlay ghc-type-overlay)))
(defun ghc-show-type ()
(interactive)
(if (not (ghc-which ghc-module-command))
(message "%s not found" ghc-module-command)
(let ((modname (ghc-find-module-name)))
(if (not modname)
(message "module should be specified")
(ghc-show-type0 modname)))))
(defun ghc-show-type0 (modname)
(let* ((buf (current-buffer))
(types (ghc-get-type modname))
(tinfo (nth (ghc-type-get-ix) types))
(pos (nth 0 tinfo))
(type (nth 1 tinfo))
(left (ghc-get-pos buf (nth 0 pos) (nth 1 pos)))
(right (ghc-get-pos buf (nth 2 pos) (nth 3 pos))))
(move-overlay ghc-type-overlay (- left 1) (- right 1) buf)
(message type)))
(defun ghc-get-type (modname)
(if (= (ghc-type-get-point) (point))
(ghc-type-set-ix
(mod (1+ (ghc-type-get-ix)) (length (ghc-type-get-types))))
(ghc-type-set-types (ghc-call-type modname))
(ghc-type-set-point (point))
(ghc-type-set-ix 0))
(ghc-type-get-types))
(defun ghc-call-type (modname)
(let* ((ln (int-to-string (line-number-at-pos)))
(cn (int-to-string (current-column)))
(cdir default-directory)
(file (buffer-name)))
(ghc-read-lisp
(lambda ()
(cd cdir)
(apply 'call-process ghc-module-command nil t nil
`(,@(ghc-make-ghc-options) "type" ,file ,modname ,ln ,cn))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Misc
;;;
(defun ghc-get-pos (buf line col)
(save-excursion
(set-buffer buf)
(goto-line line)
(forward-char col)
(point)))
(defun ghc-read-expression (default)
(if default
(let ((prompt (format "Expression (%s): " default)))
(read-string prompt default nil))
(read-string "Expression: ")))
(defun ghc-find-module-name ()
(save-excursion
(goto-char (point-min))
(if (re-search-forward "^module[ ]+\\([^ ]+\\)" nil t)
(match-string-no-properties 1))))
(provide 'ghc-info)