elisp/geiser-guile.el

   1 ;; geiser-guile.el -- guile's implementation of the geiser protocols
   2
   3 ;; Copyright (C) 2009 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: Sun Mar 08, 2009 23:03
  11
  12 \f
  13
  14 (require 'geiser-syntax)
  15 (require 'geiser-custom)
  16 (require 'geiser-base)
  17 (require 'geiser-eval)
  18 (require 'geiser-edit)
  19 (require 'geiser)
  20
  21 \f
  22 ;;; Customization:
  23
  24 (defgroup geiser-guile nil
  25   "Customization for Geiser's Guile flavour."
  26   :group 'geiser)
  27
  28 (geiser-custom--defcustom geiser-guile-binary
  29   (cond ((eq system-type 'windows-nt) "guile.exe")
  30         ((eq system-type 'darwin) "guile")
  31         (t "guile"))
  32   "Name to use to call the Guile executable when starting a REPL."
  33   :type '(choice string (repeat string))
  34   :group 'geiser-guile)
  35
  36 (geiser-custom--defcustom geiser-guile-load-path nil
  37   "A list of paths to be added to Guile's load path when it's
  38 started."
  39   :type '(repeat file)
  40   :group 'geiser-guile)
  41
  42 (geiser-custom--defcustom geiser-guile-init-file "~/.guile-geiser"
  43   "Initialization file with user code for the Guile REPL."
  44   :type 'string
  45   :group 'geiser-guile)
  46
  47 (geiser-custom--defcustom geiser-guile-use-compiler-in-eval t
  48   "When enable, always use Guile's compiler to perform evaluation.
  49 Recommended, since the compiler usually collects better metadata
  50 than the interpreter."
  51   :type 'boolean
  52   :group 'geiser-guile)
  53
  54 \f
  55 ;;; REPL support:
  56
  57 (defun geiser-guile-binary ()
  58   (if (listp geiser-guile-binary) (car geiser-guile-binary) geiser-guile-binary))
  59
  60 (defun geiser-guile-parameters ()
  61   "Return a list with all parameters needed to start Guile.
  62 This function uses `geiser-guile-init-file' if it exists."
  63   (let ((init-file (and (stringp geiser-guile-init-file)
  64                         (expand-file-name geiser-guile-init-file))))
  65   `(,@(and (listp geiser-guile-binary) (cdr geiser-guile-binary))
  66     "-q" "-L" ,(expand-file-name "guile/" geiser-scheme-dir)
  67     ,@(apply 'append (mapcar (lambda (p) (list "-L" p)) geiser-guile-load-path))
  68     ,@(and init-file (file-readable-p init-file) (list "-l" init-file)))))
  69
  70 (defconst geiser-guile-prompt-regexp "^[^() \n]+@([^)]*?)> ")
  71
  72 (defun switch-to-guile (&optional ask)
  73   (interactive "P")
  74   (switch-to-geiser ask 'guile))
  75
  76 (defun run-guile ()
  77   "Run Geiser using Guile."
  78   (interactive)
  79   (run-geiser 'guile))
  80
  81 \f
  82 ;;; Evaluation support:
  83
  84 (defun geiser-guile-geiser-procedure (proc)
  85   (let ((proc (intern (format "ge:%s"
  86                               (if (and geiser-guile-use-compiler-in-eval
  87                                        (eq proc 'eval))
  88                                   'compile
  89                                 proc)))))
  90     `(@ (geiser emacs) ,proc)))
  91
  92 (defconst geiser-guile--module-re
  93   "(define-module +\\(([^)]+)\\)")
  94
  95 (defun geiser-guile-get-module (&optional module)
  96   (cond ((null module)
  97          (save-excursion
  98            (goto-char (point-min))
  99            (if (re-search-forward geiser-guile--module-re nil t)
 100                (geiser-guile-get-module (match-string-no-properties 1))
 101              :f)))
 102         ((listp module) module)
 103         ((stringp module)
 104          (or (ignore-errors (car (read-from-string module))) :f))
 105         (t :f)))
 106
 107 (defun geiser-guile-symbol-begin (module)
 108   (if module
 109       (max (save-excursion (beginning-of-line) (point))
 110            (save-excursion (skip-syntax-backward "^(>") (1- (point))))
 111     (save-excursion (skip-syntax-backward "^-()>") (point))))
 112
 113 \f
 114 ;;; Error display
 115 (defvar geiser-guile--file-cache (make-hash-table :test 'equal))
 116
 117 (defun geiser-guile--resolve-file (file)
 118   (when (and (stringp file) (not (string-equal file "unknown file")))
 119     (if (file-name-absolute-p file) file
 120       (or (gethash file geiser-guile--file-cache)
 121           (puthash file
 122                    (geiser-eval--send/result `(:eval ((:ge find-file) ,file)))
 123                    geiser-guile--file-cache)))))
 124
 125 (defconst geiser-guile--file-rx
 126   "^In \\([^\n:]+\\):\n *\\([[:digit:]]+\\|\\?\\):")
 127
 128 (defun geiser-guile--find-files ()
 129   (save-excursion
 130     (while (re-search-forward geiser-guile--file-rx nil t)
 131       (let ((file (match-string 1))
 132             (beg (match-beginning 1))
 133             (end (match-end 1))
 134             (line (string-to-number (or (match-string 2) "0"))))
 135         (let ((file (geiser-guile--resolve-file file)))
 136           (when file
 137             (geiser-edit--make-link beg end file line 0)))))))
 138
 139 (defun geiser-guile-display-error (module key msg)
 140   (when key
 141     (insert "Error: ")
 142     (geiser--insert-with-face (format "%s" key) 'bold)
 143     (newline 2))
 144   (when msg
 145     (let ((p (point)))
 146       (insert msg)
 147       (goto-char p)
 148       (geiser-guile--find-files)))
 149   t)
 150
 151 \f
 152 ;;; Trying to ascertain whether a buffer is Guile Scheme:
 153
 154 (defun geiser-guile-guess ()
 155   "Return `t' if the current buffer looks like a Guile file."
 156   (listp (geiser-guile-get-module)))
 157
 158 \f
 159 (provide 'geiser-guile)
 160 ;;; geiser-guile.el ends here