refoctoring elisp.

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

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)