New buttons (source, forward/backward) in document browser.

4 files changed, 102 insertions, 40 deletions

diff --git a/elisp/geiser-doc.el b/elisp/geiser-doc.el
index ef20938..f6ef1e2 100644
--- a/elisp/geiser-doc.el
+++ b/elisp/geiser-doc.el
@@ -11,6 +11,7 @@
 
 
 
+(require 'geiser-edit)
 (require 'geiser-impl)
 (require 'geiser-completion)
 (require 'geiser-autodoc)
@@ -35,6 +36,9 @@
 (geiser-custom--defface doc-link
   'link geiser-doc "links in documentation buffers")
 
+(geiser-custom--defface doc-button
+  'button geiser-doc "buttons in documentation buffers")
+
 
 ;;; Documentation browser history:
 
@@ -49,22 +53,30 @@
   (car geiser-doc--history))
 
 (defun geiser-doc--history-push (link)
-  (unless (or (null link) (equal link (car geiser-doc--history)))
-    (let ((next (geiser-doc--history-next)))
-      (unless (equal link next)
-        (when next (geiser-doc--history-previous))
-        (ring-insert (nth 1 geiser-doc--history) (car geiser-doc--history))
-        (setcar geiser-doc--history link))))
+  (unless (or (null link) (equal link (geiser-doc--history-current)))
+    (when (not (null (geiser-doc--history-current)))
+      (let ((next (geiser-doc--history-next)))
+        (unless (equal link next)
+          (when next (geiser-doc--history-previous))
+          (ring-insert (nth 1 geiser-doc--history)
+                       (car geiser-doc--history)))))
+    (setcar geiser-doc--history link))
   link)
 
+(defsubst geiser-doc--history-next-p ()
+  (not (ring-empty-p (nth 2 geiser-doc--history))))
+
 (defun geiser-doc--history-next (&optional forget-current)
-  (when (not (ring-empty-p (nth 2 geiser-doc--history)))
+  (when (geiser-doc--history-next-p)
     (when (and (car geiser-doc--history) (not forget-current))
       (ring-insert (nth 1 geiser-doc--history) (car geiser-doc--history)))
     (setcar geiser-doc--history (ring-remove (nth 2 geiser-doc--history) 0))))
 
+(defsubst geiser-doc--history-previous-p ()
+  (not (ring-empty-p (nth 1 geiser-doc--history))))
+
 (defun geiser-doc--history-previous (&optional forget-current)
-  (when (not (ring-empty-p (nth 1 geiser-doc--history)))
+  (when (geiser-doc--history-previous-p)
     (when (and (car geiser-doc--history) (not forget-current))
       (ring-insert (nth 2 geiser-doc--history) (car geiser-doc--history)))
     (setcar geiser-doc--history (ring-remove (nth 1 geiser-doc--history) 0))))
@@ -97,6 +109,12 @@
             (geiser-doc-module module impl)
           (geiser-doc-symbol target module impl))))))
 
+(make-variable-buffer-local
+ (defvar geiser-doc--buffer-link nil))
+
+(defsubst geiser-doc--implementation ()
+  (geiser-doc--link-impl geiser-doc--buffer-link))
+
 (defun geiser-doc--button-action (button)
   (let ((link (button-get button 'geiser-link)))
     (when link (geiser-doc--follow-link link))))
@@ -117,10 +135,48 @@
                         'geiser-link link
                         'help-echo help)))
 
+(defun geiser-doc--xbutton-action (button)
+  (when geiser-doc--buffer-link
+    (let ((kind (or (button-get button 'x-kind) 'source))
+          (target (geiser-doc--link-target geiser-doc--buffer-link))
+          (module (geiser-doc--link-module geiser-doc--buffer-link))
+          (impl (geiser-doc--link-impl geiser-doc--buffer-link)))
+      (with--geiser-implementation impl
+        (if (eq kind 'source)
+            (if target (geiser-edit-symbol target nil (point-marker))
+              (geiser-edit-module module)))))))
+
+(define-button-type 'geiser-doc--xbutton
+  'action 'geiser-doc--xbutton-action
+  'face 'geiser-font-lock-doc-button
+  'follow-link t)
+
+(defun geiser-doc--insert-xbutton (&optional manual)
+  (insert-text-button (if manual "[manual]" "[source]")
+                      :type 'geiser-doc--xbutton
+                      'x-kind (if manual 'manual 'source)))
+
+(defun geiser-doc--insert-xbuttons ()
+  (geiser-doc--insert-xbutton))
+
+(defun geiser-doc--insert-footer ()
+  (newline)
+  (when (geiser-doc--history-previous-p)
+    (insert-text-button "[back]"
+                        'action '(lambda (b) (geiser-doc-previous))
+                        'face 'geiser-font-lock-doc-button
+                        'follow-link t)
+    (insert "  "))
+  (when (geiser-doc--history-next-p)
+    (insert-text-button "[forward]"
+                        'action '(lambda (b) (geiser-doc-next))
+                        'face 'geiser-font-lock-doc-button
+                        'follow-link t)))
+
 
 ;;; Auxiliary functions:
 
-(defun geiser-doc--insert-title (title)
+(defun geiser-doc--insert-title (title &optional top)
   (let ((p (point)))
     (if (not (listp title))
         (insert (format "%s" title))
@@ -129,6 +185,12 @@
         (insert " " (if (eq a '\#:rest) "." (format "%s" a))))
       (insert ")"))
     (put-text-property p (point) 'face 'geiser-font-lock-doc-title)
+    (when top
+      (let ((len (max 1 (- (window-width)
+                           (- (point) (line-beginning-position))
+                           10))))
+        (insert (make-string len ?\ ))
+        (geiser-doc--insert-xbuttons)))
     (newline)))
 
 (defun geiser-doc--insert-list (title lst module impl)
@@ -143,12 +205,6 @@
       (newline))
     (newline)))
 
-(make-variable-buffer-local
- (defvar geiser-doc--buffer-link nil))
-
-(defsubst geiser-doc--implementation ()
-  (geiser-doc--link-impl geiser-doc--buffer-link))
-
 
 ;;; Commands:
 
@@ -178,13 +234,15 @@ help (e.g. browse an HTML page) implementing this method.")
             (erase-buffer)
             (geiser-doc--insert-title
              (geiser-autodoc--str (list (symbol-name symbol) 0)
-                                  (cdr (assoc 'signature ds))))
+                                  (cdr (assoc 'signature ds)))
+             t)
             (newline)
             (insert (or (cdr (assoc 'docstring ds)) ""))
-            (goto-char (point-min))
             (setq geiser-doc--buffer-link
                   (geiser-doc--history-push
-                   (geiser-doc--make-link symbol module impl))))
+                   (geiser-doc--make-link symbol module impl)))
+            (geiser-doc--insert-footer)
+            (goto-char (point-min)))
           (geiser-doc--pop-to-buffer))))))
 
 (defun geiser-doc-symbol-at-point (&optional arg)
@@ -207,7 +265,7 @@ With prefix argument, ask for symbol (with completion)."
         (message "No information available for %s" module)
       (geiser-doc--with-buffer
         (erase-buffer)
-        (geiser-doc--insert-title (format "%s" module))
+        (geiser-doc--insert-title (format "%s" module) t)
         (newline)
         (dolist (g '(("Procedures:" . procs)
                      ("Variables:" . vars)
@@ -220,10 +278,11 @@ With prefix argument, ask for symbol (with completion)."
                                  (cdr (assoc 'modules exports))
                                  nil
                                  impl)
-        (goto-char (point-min))
         (setq geiser-doc--buffer-link
               (geiser-doc--history-push
-               (geiser-doc--make-link nil module impl))))
+               (geiser-doc--make-link nil module impl)))
+        (geiser-doc--insert-footer)
+        (goto-char (point-min)))
       (geiser-doc--pop-to-buffer))))
 
 (defun geiser-doc-next (&optional forget-current)
diff --git a/elisp/geiser-edit.el b/elisp/geiser-edit.el
index 7a62a5c..8d25133 100644
--- a/elisp/geiser-edit.el
+++ b/elisp/geiser-edit.el
@@ -145,14 +145,15 @@ or following links in error buffers.")
 
 (defvar geiser-edit--symbol-history nil)
 
-(defun geiser-edit-symbol (symbol &optional method)
+(defun geiser-edit-symbol (symbol &optional method marker)
   "Asks for a symbol to edit, with completion."
   (interactive
    (list (geiser-completion--read-symbol "Edit symbol: "
                                          nil
                                          geiser-edit--symbol-history)))
   (let ((cmd `(:eval ((:ge symbol-location) ',symbol))))
-    (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method)))
+    (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method)
+    (when marker (ring-insert find-tag-marker-ring marker))))
 
 (defun geiser-edit-symbol-at-point (&optional arg)
   "Opens a new window visiting the definition of the symbol at point.
diff --git a/elisp/geiser-reload.el b/elisp/geiser-reload.el
index d9ba4d2..f01cacf 100644
--- a/elisp/geiser-reload.el
+++ b/elisp/geiser-reload.el
@@ -1,6 +1,6 @@
 ;; geiser-reload.el -- unload/load geiser packages
 
-;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
 
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the Modified BSD License. You should
@@ -25,11 +25,11 @@
            geiser-mode
            geiser-repl
            geiser-xref
-           geiser-edit
            geiser-doc
            geiser-debug
            geiser-impl
            geiser-company
+           geiser-edit
            geiser-completion
            geiser-autodoc
            geiser-compile
diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el
index e0d9634..040e122 100644
--- a/elisp/geiser-syntax.el
+++ b/elisp/geiser-syntax.el
@@ -205,23 +205,25 @@
 (defsubst geiser-syntax--pair-length (p)
   (if (cdr (last p)) (1+ (safe-length p)) (length p)))
 
-(defun geiser-syntax--scan-sexps ()
+(defun geiser-syntax--scan-sexps (&optional begin)
   (let ((path))
     (save-excursion
-      (geiser-syntax--skip-comment/string)
-      (while (not (zerop (geiser-syntax--nesting-level)))
-        (let ((boundary (1+ (point))))
-          (backward-up-list)
-          (let ((form
-                 (nth-value 0 (geiser-syntax--form-after-point boundary))))
-            (when (and (listp form) (car form) (symbolp (car form)))
-              (let* ((len-1 (1- (geiser-syntax--pair-length form)))
-                     (prev (and (> len-1 1) (nth (1- len-1) form)))
-                     (prev (and (keywordp prev) (list prev))))
-                (push `(,(car form) ,len-1 ,@prev) path)))))))
-    (if path (nreverse path)
-      (let ((fst (symbol-at-point)))
-        (and fst `((,fst 0)))))))
+      (save-restriction
+        (narrow-to-region (or begin (point-min)) (1+ (point)))
+        (geiser-syntax--skip-comment/string)
+        (while (not (zerop (geiser-syntax--nesting-level)))
+          (let ((boundary (1+ (point))))
+            (backward-up-list)
+            (let ((form
+                   (nth-value 0 (geiser-syntax--form-after-point boundary))))
+              (when (and (listp form) (car form) (symbolp (car form)))
+                (let* ((len-1 (1- (geiser-syntax--pair-length form)))
+                       (prev (and (> len-1 1) (nth (1- len-1) form)))
+                       (prev (and (keywordp prev) (list prev))))
+                  (push `(,(car form) ,len-1 ,@prev) path))))))
+        (if path (nreverse path)
+          (let ((fst (symbol-at-point)))
+            (and fst `((,fst 0)))))))))
 
 (defsubst geiser-syntax--binding-form-p (bfs sbfs f)
   (or (memq f '(define define* lambda let let* letrec))