elisp/geiser-edit.el

   1 ;;; geiser-edit.el -- scheme edit locations
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Wed Feb 11, 2009 21:07
  11
  12 \f
  13
  14 (require 'geiser-completion)
  15 (require 'geiser-eval)
  16 (require 'geiser-custom)
  17 (require 'geiser-base)
  18
  19 (require 'etags)
  20
  21 \f
  22 ;;; Customization:
  23
  24 (defmacro geiser-edit--define-custom-visit (var group doc)
  25   `(geiser-custom--defcustom ,var nil
  26      ,doc
  27      :group ',group
  28      :type '(choice (const :tag "Other window" window)
  29                     (const :tag "Other frame" frame)
  30                     (const :tag "Current window" nil))))
  31
  32 (geiser-edit--define-custom-visit
  33  geiser-edit-symbol-method geiser-mode
  34  "How the new buffer is opened when invoking \\[geiser-edit-symbol-at-point]
  35 or following links in error buffers.")
  36
  37 (geiser-custom--defface error-link
  38   'link geiser-debug "links in error buffers")
  39
  40 \f
  41 ;;; Auxiliar functions:
  42
  43 (defun geiser-edit--visit-file (file method)
  44   (cond ((eq method 'window) (find-file-other-window file))
  45         ((eq method 'frame) (find-file-other-frame file))
  46         ((eq method 'noselect) (find-file-noselect file t))
  47         (t (find-file file))))
  48
  49 (defsubst geiser-edit--location-name (loc)
  50   (cdr (assoc 'name loc)))
  51
  52 (defsubst geiser-edit--location-file (loc)
  53   (cdr (assoc 'file loc)))
  54
  55 (defsubst geiser-edit--to-number (x)
  56   (cond ((numberp x) x)
  57         ((stringp x) (string-to-number x))))
  58
  59 (defsubst geiser-edit--location-line (loc)
  60   (geiser-edit--to-number (cdr (assoc 'line loc))))
  61
  62 (defsubst geiser-edit--location-column (loc)
  63   (geiser-edit--to-number (cdr (assoc 'column loc))))
  64
  65 (defsubst geiser-edit--make-location (name file line column)
  66   `((name . ,name) (file . ,file) (line . ,line) (column . ,column)))
  67
  68 (defconst geiser-edit--def-re
  69   (regexp-opt '("define"
  70                 "defmacro"
  71                 "define-macro"
  72                 "define-syntax"
  73                 "define-syntax-rule"
  74                 "-define-syntax"
  75                 "-define"
  76                 "define*"
  77                 "define-method"
  78                 "define-class"
  79                 "define-struct")))
  80
  81 (defconst geiser-edit--def-re*
  82   (regexp-opt '("define-syntaxes" "define-values")))
  83
  84 (defsubst geiser-edit--def-re (thing)
  85   (format "(%s +(?%s\\_>"
  86           geiser-edit--def-re
  87           (regexp-quote (format "%s" thing))))
  88
  89 (defsubst geiser-edit--def-re* (thing)
  90   (format "(%s +([^)]*?\\_<%s\\_>"
  91           geiser-edit--def-re*
  92           (regexp-quote (format "%s" thing))))
  93
  94 (defsubst geiser-edit--symbol-re (thing)
  95   (format "\\_<%s\\_>" (regexp-quote (format "%s" thing))))
  96
  97 (defun geiser-edit--goto-line (symbol line)
  98   (goto-char (point-min))
  99   (if (numberp line)
 100       (forward-line (max 0 (1- line)))
 101     (goto-char (point-min))
 102     (when (or (re-search-forward (geiser-edit--def-re symbol) nil t)
 103               (re-search-forward (geiser-edit--def-re* symbol) nil t)
 104               (re-search-forward (geiser-edit--symbol-re symbol) nil t))
 105       (goto-char (match-beginning 0)))))
 106
 107 (defun geiser-edit--try-edit-location (symbol loc &optional method)
 108   (let ((symbol (or (geiser-edit--location-name loc) symbol))
 109         (file (geiser-edit--location-file loc))
 110         (line (geiser-edit--location-line loc))
 111         (col (geiser-edit--location-column loc)))
 112     (unless file (error "Couldn't find edit location for '%s'" symbol))
 113     (unless (file-readable-p file) (error "Couldn't open '%s' for read" file))
 114     (geiser-edit--visit-file file (or method geiser-edit-symbol-method))
 115     (geiser-edit--goto-line symbol line)
 116     (when col
 117       (beginning-of-line)
 118       (forward-char col))
 119     (cons (current-buffer) (point))))
 120
 121 (defsubst geiser-edit--try-edit (symbol ret &optional method)
 122   (geiser-edit--try-edit-location symbol (geiser-eval--retort-result ret) method))
 123
 124 \f
 125 ;;; Links
 126
 127 (define-button-type 'geiser-edit--button
 128   'action 'geiser-edit--button-action
 129   'face 'geiser-font-lock-error-link
 130   'follow-link t)
 131
 132 (defun geiser-edit--button-action (button)
 133   (let ((loc (button-get button 'geiser-location))
 134         (method (button-get button 'geiser-method)))
 135     (when loc (geiser-edit--try-edit-location nil loc method))))
 136
 137 (defun geiser-edit--make-link (beg end file line col &optional method)
 138   (make-button beg end
 139                :type 'geiser-edit--button
 140                'geiser-method method
 141                'geiser-location
 142                (geiser-edit--make-location 'error file line col)
 143                'help-echo "Go to error location"))
 144
 145 \f
 146 ;;; Commands:
 147
 148 (defvar geiser-edit--symbol-history nil)
 149
 150 (defun geiser-edit-symbol (symbol &optional method marker)
 151   "Asks for a symbol to edit, with completion."
 152   (interactive
 153    (list (geiser-completion--read-symbol "Edit symbol: "
 154                                          nil
 155                                          geiser-edit--symbol-history)))
 156   (let ((cmd `(:eval ((:ge symbol-location) ',symbol))))
 157     (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method)
 158     (when marker (ring-insert find-tag-marker-ring marker))))
 159
 160 (defun geiser-edit-symbol-at-point (&optional arg)
 161   "Opens a new window visiting the definition of the symbol at point.
 162 With prefix, asks for the symbol to edit."
 163   (interactive "P")
 164   (let* ((symbol (or (and (not arg) (symbol-at-point))
 165                      (geiser-completion--read-symbol "Edit symbol: ")))
 166          (cmd `(:eval ((:ge symbol-location) ',symbol)))
 167          (marker (point-marker)))
 168     (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd))
 169     (when marker (ring-insert find-tag-marker-ring marker))))
 170
 171 (defun geiser-pop-symbol-stack ()
 172   "Pop back to where \\[geiser-edit-symbol-at-point] was last invoked."
 173   (interactive)
 174   (condition-case nil
 175       (pop-tag-mark)
 176     (error "No previous location for find symbol invocation")))
 177
 178 (defun geiser-edit-module (module &optional method)
 179   "Asks for a module and opens it in a new buffer."
 180   (interactive (list (geiser-completion--read-module)))
 181   (let ((cmd `(:eval ((:ge module-location) (:module ,module)))))
 182     (geiser-edit--try-edit module (geiser-eval--send/wait cmd) method)))
 183
 184 \f
 185 (provide 'geiser-edit)
 186 ;;; geiser-edit.el ends here