Dan's Custom Scheme for Emacs

custom-scheme.el

(require 'paredit)
(require 'auto-complete)
(require 'auto-complete-etags)
(require 'yasnippet-bundle)
(require 'scheme)

;; Some utilities of mine
(defun add-font-lock-keywords (modes new-keywords)
  (mapc (lambda (mode)
          (font-lock-add-keywords mode `((, (concat "(\\(" (regexp-opt (mapcar 'symbol-name (remove-if 'numberp new-keywords)) t) "\\)\\>")
                                            (1 font-lock-keyword-face)))))
        modes)
  t)

(defun remove-font-lock-keywords (modes new-keywords)
  (mapc (lambda (mode)
          (font-lock-remove-keywords mode `((, (concat "(\\(" (regexp-opt (mapcar 'symbol-name (remove-if 'numberp new-keywords)) t) "\\)\\>")
                                               (1 font-lock-keyword-face)))))
        modes)
  t)

;; Set this to a target etags file of your choosing
(defcustom chicken-scheme-tags-file nil
  "Extra tags file to load for pattern matching and syntax hilighting"
  :type '(string)
  :group 'chicken-scheme)

;; Hardcoded r5rs-symbols
(setq r5rs-symbols '(abs acos and angle append apply asin assoc assq assv atan begin boolean? caar cadr call-with-current-continuation call-with-input-file call-with-output-file call-with-values car case cdddar cddddr cdr ceiling char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>? char? close-input-port close-output-port complex? cond cons cos current-input-port current-output-port define define-syntax delay denominator display do dynamic-wind else eof-object? eq? equal? eqv? eval even? exact->inexact exact? exp expt floor for-each force gcd if imag-part inexact->exact inexact? input-port? integer->char integer? interaction-environment lambda lcm length let let* let-syntax letrec letrec-syntax list list->string list->vector list-ref list-tail list? load log magnitude make-polar make-rectangular make-string make-vector map max member memq memv min modulo negative? newline not null-environment null? number->string number? numerator odd? open-input-file open-output-file or output-port? pair? peek-char port? positive? procedure? quasiquote quote quotient rational? rationalize read read-char real-part real? remainder reverse round scheme-report-environment set! set-car! set-cdr! setcar sin sqrt string string->list string->number string->symbol string-append string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? string-copy string-fill! string-length string-ref string-set! string<=? string<? string=? string>=? string>? string? substring symbol->string symbol? syntax-rules tan transcript-off transcript-on truncate values vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero?))

(defun load-scheme-tags (scheme-tags-location)
  (interactive)
  (let ((existing-tags tags-table-list))
    (setq tags-table-list nil)
    (visit-tags-table scheme-tags-location)
    (tags-completion-table)
    (add-font-lock-keywords '(scheme-mode inferior-scheme-mode) tags-completion-table)
    (setq tags-table-list existing-tags))
  t)

(defun chicken-modules ()
  (interactive "r")
  (let ((default-directory "~/")
        modules)
    (with-temp-buffer
      (insert (shell-command-to-string "chicken-status -files"))
      (beginning-of-buffer)
      (while (re-search-forward "/\\([^/\.]+\\)\\.so" nil t)
        (when (match-string 0)
          (if (and (not (equalp "chicken-doc" (match-string 1))) ; Doesn't play well with csi in emacs?
                   (not (equalp "chicken-doc-text" (match-string 1)))
                   (not (equalp "bind-translator" (match-string 1))))
              (push (match-string 1) modules)))))
    modules))

(defvar ac-chicken-symbols-source
  (eval 
   (read 
    (concat "'" 
            (shell-command-to-string 
             (format "csi -q -w -e \"(use %s)\" -e \"(display (map car (##sys#macro-environment)))\" -e \"(display (##sys#environment-symbols (interaction-environment)))\"" 
                     (mapconcat 'identity (chicken-modules) " ")))))))

(defun all-chicken-symbols ()
  (delete-dups (append r5rs-symbols ac-chicken-symbols-source)))

(defun ac-chicken-symbols-candidates ()
  (delq nil
        (mapcar '(lambda (s) (let ((n (symbol-name s)))
                               (cons n n)))
                (all-chicken-symbols))))

(defface ac-chicken-scheme-candidate-face
  '((t (:inherit 'ac-candidate-face)))
  "Face for chicken scheme candidate menu."
  :group 'chicken-scheme)

(defface ac-chicken-scheme-selection-face
  '((t (:inherit 'ac-selection-face)))
  "Face for the chicken scheme selected candidate."
  :group 'chicken-scheme)

(defun ac-chicken-doc (symbol-name)
  (shell-command-to-string (format "chicken-doc %s" (substring-no-properties symbol-name))))

(defun load-chicken-keywords ()
  (interactive "r")
  (add-font-lock-keywords '(scheme-mode) (all-chicken-symbols)))

(defvar ac-source-scheme-symbols
  '((candidates . ac-chicken-symbols-candidates)
    (candidate-face . ac-chicken-scheme-candidate-face)
    (selection-face . ac-chicken-scheme-selection-face)
    (symbol . "c")
    (requires . 2)
    (document . ac-chicken-doc)))

(add-hook 'scheme-mode-hook
          '(lambda ()
             (enable-paredit-mode)
             (if chicken-scheme-tags-file
                 (load-scheme-tags scheme-tags-file))
             (setq ac-sources 
                   '(ac-source-scheme-symbols
                     ac-source-words-in-buffer
                     ))
             (load-chicken-keywords)
			 ))

(provide 'custom-scheme)