diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index af4172d..a516701 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -55,53 +55,89 @@ (buffer-substring (point-min) (1- (point-max)))))) (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)) (message "%s not found" ghc-module-command) (let ((modname (ghc-find-module-name))) (if (not modname) (message "module should be specified") - (ghc-show-annot0 ask modname))))) + (ghc-show-annot0 modname))))) -(defvar *annot-point* 0) -(defvar *annot-ix* 0) -(defvar *annot-ovl* (make-overlay 0 0)) -(overlay-put *annot-ovl* 'face 'region) +(defun ghc-show-annot0 (modname) + (let* ((buf (current-buffer)) + (types (ghc-get-annot modname)) + (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) - (delete-overlay *annot-ovl*)) +(defun ghc-get-annot (modname) + (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 - (cons 'delete-annot-ovl - after-change-functions)) - -(defun ghc-show-annot0 (ask modname) - (let* ((pt (point)) - (ln (int-to-string (line-number-at-pos))) - (cn (int-to-string (current-column))) +(defun ghc-call-annot (modname) + (let* ((ln (int-to-string (line-number-at-pos))) + (cn (int-to-string (current-column))) (cdir default-directory) - (buf (current-buffer)) (file (buffer-name))) - (if (= *annot-point* pt) - (setq *annot-ix* (+ 1 *annot-ix*)) - (progn - (setq *annot-point* pt) - (setq *annot-ix* 0))) - (save-excursion - (with-temp-buffer - (cd cdir) - (apply 'call-process ghc-module-command nil t nil - `(,@(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)))))) + (ghc-read-lisp + (lambda () + (cd cdir) + (apply 'call-process ghc-module-command nil t nil + `(,@(ghc-make-ghc-options) "annot" ,file ,modname ,ln ,cn)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Misc +;;; (defun ghc-get-pos (buf line col) (save-excursion diff --git a/elisp/ghc.el b/elisp/ghc.el index a73773f..995f15e 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -64,6 +64,7 @@ (defun ghc-init () (ghc-abbrev-init) + (ghc-annot-init) (unless ghc-initialized (define-key haskell-mode-map ghc-completion-key 'ghc-complete) (define-key haskell-mode-map ghc-document-key 'ghc-browse-document)