hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

refoctoring elisp.

Browse Source
This commit is contained in:
Kazu Yamamoto 2012-02-13 12:06:59 +09:00
parent 23f4365150
commit f497aa1213
2 changed files with 74 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
elisp/ghc-info.el
View File

@ -55,53 +55,89 @@
(buffer-substring (point-min) (1- (point-max)))))) (buffer-substring (point-min) (1- (point-max))))))
(display-buffer buf))) (display-buffer buf)))
(defun ghc-show-annot (&optional ask) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(interactive "P") ;;;
;;; annot
;;;
(defvar ghc-annot-overlay nil)
(make-variable-buffer-local 'ghc-annot-overlay)
(defun ghc-annot-set-ix (n)
(overlay-put ghc-annot-overlay 'ix n))
(defun ghc-annot-get-ix ()
(overlay-get ghc-annot-overlay 'ix))
(defun ghc-annot-set-point (pos)
(overlay-put ghc-annot-overlay 'pos pos))
(defun ghc-annot-get-point ()
(overlay-get ghc-annot-overlay 'pos))
(defun ghc-annot-set-types (types)
(overlay-put ghc-annot-overlay 'types types))
(defun ghc-annot-get-types ()
(overlay-get ghc-annot-overlay 'types))
(defun ghc-annot-init ()
(setq ghc-annot-overlay (make-overlay 0 0))
(overlay-put ghc-annot-overlay 'face 'region)
(ghc-annot-set-ix 0)
(ghc-annot-set-point 0)
(setq after-change-functions
(cons 'ghc-delete-annot-ovl after-change-functions)))
(defun ghc-delete-annot-ovl (beg end len)
(when (overlayp ghc-annot-overlay)
(delete-overlay ghc-annot-overlay)))
(defun ghc-show-annot ()
(interactive)
(if (not (ghc-which ghc-module-command)) (if (not (ghc-which ghc-module-command))
(message "%s not found" ghc-module-command) (message "%s not found" ghc-module-command)
(let ((modname (ghc-find-module-name))) (let ((modname (ghc-find-module-name)))
(if (not modname) (if (not modname)
(message "module should be specified") (message "module should be specified")
(ghc-show-annot0 ask modname))))) (ghc-show-annot0 modname)))))
(defvar *annot-point* 0) (defun ghc-show-annot0 (modname)
(defvar *annot-ix* 0) (let* ((buf (current-buffer))
(defvar *annot-ovl* (make-overlay 0 0)) (types (ghc-get-annot modname))
(overlay-put *annot-ovl* 'face 'region) (tinfo (nth (ghc-annot-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-annot-overlay (- left 1) (- right 1) buf)
(message type)))
(defun delete-annot-ovl (beg end len) (defun ghc-get-annot (modname)
(delete-overlay *annot-ovl*)) (if (= (ghc-annot-get-point) (point))
(ghc-annot-set-ix
(mod (1+ (ghc-annot-get-ix)) (length (ghc-annot-get-types))))
(ghc-annot-set-types (ghc-call-annot modname))
(ghc-annot-set-point (point))
(ghc-annot-set-ix 0))
(ghc-annot-get-types))
(setq after-change-functions (defun ghc-call-annot (modname)
(cons 'delete-annot-ovl (let* ((ln (int-to-string (line-number-at-pos)))
after-change-functions)) (cn (int-to-string (current-column)))
(defun ghc-show-annot0 (ask modname)
(let* ((pt (point))
(ln (int-to-string (line-number-at-pos)))
(cn (int-to-string (current-column)))
(cdir default-directory) (cdir default-directory)
(buf (current-buffer))
(file (buffer-name))) (file (buffer-name)))
(if (= *annot-point* pt) (ghc-read-lisp
(setq *annot-ix* (+ 1 *annot-ix*)) (lambda ()
(progn (cd cdir)
(setq *annot-point* pt) (apply 'call-process ghc-module-command nil t nil
(setq *annot-ix* 0))) `(,@(ghc-make-ghc-options) "annot" ,file ,modname ,ln ,cn))))))
(save-excursion
(with-temp-buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cd cdir) ;;;
(apply 'call-process ghc-module-command nil t nil ;;; Misc
`(,@(ghc-make-ghc-options) "annot" ,file ,modname ,ln ,cn)) ;;;
(let* ((types (read (buffer-substring (point-min) (1- (point-max)))))
(cix (mod *annot-ix* (length types)))
(tinfo (nth cix 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 *annot-ovl* (- left 1) (- right 1) buf)
(message type))))))
(defun ghc-get-pos (buf line col) (defun ghc-get-pos (buf line col)
(save-excursion (save-excursion

1
elisp/ghc.el
View File

@ -64,6 +64,7 @@
(defun ghc-init () (defun ghc-init ()
(ghc-abbrev-init) (ghc-abbrev-init)
(ghc-annot-init)
(unless ghc-initialized (unless ghc-initialized
(define-key haskell-mode-map ghc-completion-key 'ghc-complete) (define-key haskell-mode-map ghc-completion-key 'ghc-complete)
(define-key haskell-mode-map ghc-document-key 'ghc-browse-document) (define-key haskell-mode-map ghc-document-key 'ghc-browse-document)