ghc-mod/elisp/ghc-info.el

169 lines
4.6 KiB
EmacsLisp
Raw Normal View History

2010-11-15 03:46:55 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc-info.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; Created: Nov 15, 2010
;;; Code:
(require 'ghc-func)
2010-11-15 05:46:59 +00:00
(defun ghc-show-info (&optional ask)
(interactive "P")
(let* ((expr0 (ghc-things-at-point))
(expr (if (or ask (not expr0)) (ghc-read-expression expr0) expr0))
(info (ghc-get-info expr)))
(when info
(ghc-display
nil
(lambda () (insert info))))))
(defun ghc-get-info (expr)
(let* ((modname (or (ghc-find-module-name) "Main"))
2012-02-15 02:03:51 +00:00
(file (buffer-file-name))
2012-02-27 03:53:33 +00:00
(cmds (list "info" file modname expr)))
(ghc-run-ghc-mod cmds)))
2010-11-15 05:46:59 +00:00
2012-02-13 03:06:59 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
2012-02-13 04:23:04 +00:00
;;; type
2012-02-13 03:06:59 +00:00
;;;
2012-02-13 04:23:04 +00:00
(defvar ghc-type-overlay nil)
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(make-variable-buffer-local 'ghc-type-overlay)
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-type-set-ix (n)
(overlay-put ghc-type-overlay 'ix n))
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-type-get-ix ()
(overlay-get ghc-type-overlay 'ix))
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-type-set-point (pos)
(overlay-put ghc-type-overlay 'pos pos))
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-type-get-point ()
(overlay-get ghc-type-overlay 'pos))
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-type-set-types (types)
(overlay-put ghc-type-overlay 'types types))
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-type-get-types ()
(overlay-get ghc-type-overlay 'types))
2012-02-13 03:06:59 +00:00
2012-02-13 04:38:06 +00:00
(ghc-defstruct tinfo beg-line beg-column end-line end-column info)
2012-02-13 04:23:04 +00:00
(defun ghc-type-init ()
(setq ghc-type-overlay (make-overlay 0 0))
(overlay-put ghc-type-overlay 'face 'region)
2012-02-15 02:20:24 +00:00
(ghc-type-clear-overlay)
2012-02-13 03:06:59 +00:00
(setq after-change-functions
2012-02-15 02:20:24 +00:00
(cons 'ghc-type-clear-overlay after-change-functions))
(add-hook 'post-command-hook 'ghc-type-post-command-hook))
2012-02-13 03:06:59 +00:00
2012-02-15 02:20:24 +00:00
(defun ghc-type-clear-overlay (&optional beg end len)
2012-02-13 04:23:04 +00:00
(when (overlayp ghc-type-overlay)
2012-02-15 02:20:24 +00:00
(ghc-type-set-ix 0)
(ghc-type-set-point 0)
(move-overlay ghc-type-overlay 0 0)))
2012-02-13 03:06:59 +00:00
2012-02-13 08:01:13 +00:00
(defun ghc-type-post-command-hook ()
(when (and (eq major-mode 'haskell-mode)
(overlayp ghc-type-overlay)
2012-02-13 08:01:13 +00:00
(/= (ghc-type-get-point) (point)))
2012-02-15 02:20:24 +00:00
(ghc-type-clear-overlay)))
2012-02-13 08:01:13 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-show-type ()
2012-02-13 03:06:59 +00:00
(interactive)
(if (not (executable-find ghc-module-command))
2012-02-12 16:01:58 +00:00
(message "%s not found" ghc-module-command)
2012-02-16 05:50:15 +00:00
(let ((modname (or (ghc-find-module-name) "Main")))
(ghc-show-type0 modname))))
2012-02-13 03:06:59 +00:00
2012-02-13 04:23:04 +00:00
(defun ghc-show-type0 (modname)
2012-02-13 03:06:59 +00:00
(let* ((buf (current-buffer))
2012-02-13 04:48:41 +00:00
(tinfos (ghc-type-get-tinfos modname)))
(if (null tinfos)
2012-02-15 02:20:24 +00:00
(progn
(ghc-type-clear-overlay)
(message "Cannot guess type"))
2012-02-13 04:48:41 +00:00
(let* ((tinfo (nth (ghc-type-get-ix) tinfos))
(type (ghc-tinfo-get-info tinfo))
(beg-line (ghc-tinfo-get-beg-line tinfo))
(beg-column (ghc-tinfo-get-beg-column tinfo))
(end-line (ghc-tinfo-get-end-line tinfo))
(end-column (ghc-tinfo-get-end-column tinfo))
(left (ghc-get-pos buf beg-line beg-column))
(right (ghc-get-pos buf end-line end-column)))
(move-overlay ghc-type-overlay (- left 1) (- right 1) buf)
(message type)))))
2012-02-13 04:38:06 +00:00
(defun ghc-type-get-tinfos (modname)
2012-02-13 04:23:04 +00:00
(if (= (ghc-type-get-point) (point))
(ghc-type-set-ix
(mod (1+ (ghc-type-get-ix)) (length (ghc-type-get-types))))
2014-01-12 02:54:13 +00:00
(let ((types (ghc-type-obtain-tinfos modname)))
(if (not (listp types)) ;; main does not exist in Main
(ghc-type-set-types nil)
(ghc-type-set-types (ghc-type-obtain-tinfos modname))
(ghc-type-set-point (point))
(ghc-type-set-ix 0))))
2012-02-13 04:23:04 +00:00
(ghc-type-get-types))
2012-02-13 03:06:59 +00:00
2012-02-13 04:38:06 +00:00
(defun ghc-type-obtain-tinfos (modname)
2012-02-13 03:06:59 +00:00
(let* ((ln (int-to-string (line-number-at-pos)))
2013-11-19 05:14:49 +00:00
(cn (int-to-string (1+ (current-column))))
2012-02-12 16:01:58 +00:00
(cdir default-directory)
2012-02-15 02:03:51 +00:00
(file (buffer-file-name)))
2012-02-13 03:06:59 +00:00
(ghc-read-lisp
(lambda ()
(cd cdir)
(apply 'call-process ghc-module-command nil t nil
2012-02-14 02:33:27 +00:00
`(,@(ghc-make-ghc-options) "-l" "type" ,file ,modname ,ln ,cn))
2012-02-13 08:13:27 +00:00
(goto-char (point-min))
(while (search-forward "[Char]" nil t)
(replace-match "String"))))))
2012-02-13 03:06:59 +00:00
2012-02-27 03:53:33 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Expanding Template Haskell
;;;
(defun ghc-expand-th ()
(interactive)
(let* ((file (buffer-file-name))
(cmds (list "expand" file))
(source (ghc-run-ghc-mod cmds)))
(when source
(ghc-display
'fontify
(lambda () (insert source))))))
2012-02-27 03:53:33 +00:00
2012-02-13 03:06:59 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Misc
;;;
2012-02-12 16:01:58 +00:00
(defun ghc-get-pos (buf line col)
(save-excursion
(set-buffer buf)
(goto-line line)
(forward-char col)
(point)))
2010-11-15 05:46:59 +00:00
(defun ghc-read-expression (default)
2012-01-06 02:12:28 +00:00
(if default
(let ((prompt (format "Expression (%s): " default)))
(read-string prompt default nil))
(read-string "Expression: ")))
2010-11-15 05:46:59 +00:00
(defun ghc-find-module-name ()
(save-excursion
(goto-char (point-min))
(if (re-search-forward "^module[ ]+\\([^ \n]+\\)" nil t)
(match-string-no-properties 1))))
2010-11-15 03:46:55 +00:00
(provide 'ghc-info)