;;; chicken-scheme.el --- Scheme-mode extensions for Chicken Scheme
;;
;; Copyright 2014 Daniel Leslie
;; Author: Daniel Leslie <dan@ironoxide.ca>
;; URL: http://github.com/dleslie/chicken-scheme
;; Version: 1.3.0
;;
;; Licensed under the GPL3
;; A copy of the license can be found at the above URL
;;
;;; Commentary:
;; A suite of extensions for scheme-mode that grew out of necessity.
;;
;; Chicken Scheme does play well with SLIME (See also: chicken-slime.el), but
;; I often find myself working on software that is slow-level and unstable
;; enough to make such dependence on REPL reliability rather frustrating.
;;
;; Thus chicken-scheme.el was born. It does not rely on a running Scheme to
;; provide auto-complete support for your application. A suite of customization
;; variables are available to configure from which modules symbols should be
;; loaded and what sort of package prefixes can be expected.
;;
;; Auto-complete is configured to support prefixed symbols, to allow for
;; full recognition of symbols in modules that may have been imported with a
;; prefix modifier. The `chicken-prefix` variable may be customized to declare
;; what characters can be used as prefix delimiters.
;;
;; Calling documentation for the symbol at the current point is possible with:
;; chicken-show-help
;;
;; Further customization is available in the chicken-scheme customization group.
;;
;; Loading of the first scheme file may take some time as the Chicken Modules
;; are parsed for symbols on first-load. All subsequent scheme files do not
;; incur this load hitch. Consider running an Emacs daemon.
;;
;; Installation:
;; Place in your load path. Add the following to your .emacs:
;;
;; (require 'chicken-scheme)
;; (add-hook 'scheme-mode-hook 'setup-chicken-scheme)
;; (define-key scheme-mode-map (kbd "C-?") 'chicken-show-help)
;;
;; If you don't like auto-complete, or don't want to have both R7RS and R5RS
;; symbols loaded, then don't add the setup-chicken-scheme hook. Instead,
;; the following utilities are available:
;;
;; ac-source-chicken-symbols
;; ac-source-r5rs-symbols
;; ac-source-r7rs-symbols
;; ac-source-chicken-symbols-prefixed
;; chicken-show-help
;; chicken-fix-font-lock
;;
;; Prefixed symbols are those which have been mutated after importing a library.
;; See the chicken-prefix custom variable for customization options.
;;
;; I recommend you also add the following:
;;
;; (add-hook 'scheme-mode-hook 'enable-paredit-mode)
;; (add-hook 'scheme-mode-hook 'rainbow-delimiters-mode-enable)
;;
;; This packages plays very well with the chicken-slime package.
;;
;;; Contributors:
;; Dan Leslie
;; Mao Junhua - Disk Caching
(require 'scheme)
;;; Code:
(defun chicken-dump-vars-to-file (varlist filename)
"simplistic dumping of variables in VARLIST to a file FILENAME"
(save-excursion
(let ((buf (find-file-noselect filename)))
(set-buffer buf)
(erase-buffer)
(chicken-dump-vars varlist buf)
(save-buffer)
(kill-buffer))))
(defun chicken-dump-vars (varlist buffer)
"insert into buffer the setq statement to recreate the variables in VARLIST"
(loop for var in varlist do
(print (list 'setq var (list 'quote (symbol-value var)))
buffer)))
(defun chicken-remove-error-module (module-list)
(setq del-list '("library" "foreign"))
(dolist (del-elem del-list)
(delete del-elem module-list)))
(defun chicken-installed-modules ()
"Use chicken-status to discover all installed Chicken modules."
(interactive "r")
(let ((default-directory "~/")
(modules '("srfi-1" "srfi-4" "srfi-13" "srfi-14" "srfi-18" "srfi-69" "lolevel" "tcp" "ports" "extras" "data-structures" "files" "foreign" "irregex" "library" "posix" "utils")))
(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 (equal "chicken-doc" (match-string 1))) ; Doesn't play well with csi in emacs?
(not (equal "chicken-doc-text" (match-string 1)))
(not (equal "bind-translator" (match-string 1))))
(push (match-string 1) modules)))))
modules))
(defgroup chicken-scheme
nil "Chicken Scheme Extensions")
(defcustom chicken-ac-modules (chicken-installed-modules)
"Modules to load symbols from for `auto-complete'."
:type '(repeat string)
:group 'chicken-scheme)
(defcustom chicken-prefix
;"[^:#]*[:#]\\(.*\\)"
":#"
"Defines the characters to use to identify the prefix separator that may be present for autocomplete matches. Defaults to : and #."
:type 'string
:group 'chicken-scheme)
(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)
;; Hardcoded r5rs-symbols
(defvar 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?))
(defvar r7rs-small-symbols '(* + - ... / < <= = => > >= abs and append apply assoc assq
assv begin binary-port? boolean=? boolean? bytevector
bytevector-append bytevector-copy bytevector-copy! bytevector-length
bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
call-with-current-continuation call-with-port call-with-values call/cc
car case cdar cddr cdr ceiling char->integer char-ready? char<=?
char<? char=? char>=? char>? char? close-input-port
close-output-port close-port complex? cond cond-expand cons
current-error-port current-input-port current-output-port
define define-record-type define-syntax define-values denominator do
dynamic-wind else eof-object? equal? error error-object-message
even? exact-integer-sqrt exact? features floor floor-remainder
flush-output-port gcd get-output-string if include-ci inexact?
input-port? integer? lcm let let*-values let-values letrec* list
list->vector list-ref list-tail make-bytevector make-parameter
make-vector max memq min negative? not number->string numerator
open-input-bytevector open-output-bytevector or output-port?
parameterize peek-u8 positive? quasiquote quotient raise-continuable
rationalize read-bytevector! read-error? read-string real? reverse
set! set-cdr! string string->number string->utf8 string-append
eof-object eq? eqv? error-object-irritants error-object? exact
exact-integer? expt file-error? floor-quotient floor/ for-each
get-output-bytevector guard include inexact input-port-open?
integer->char lambda length let* let-syntax letrec letrec-syntax
list->string list-copy list-set! list? make-list make-string map
member memv modulo newline null? number? odd? open-input-string
open-output-string output-port-open? pair? peek-char port?
procedure? quote raise rational? read-bytevector read-char read-line
read-u8 remainder round set-car! square string->list string->symbol
string->vector string-copy string-copy! string-for-each string-map
string-set! string<? string>=? string? symbol->string symbol?
syntax-rules truncate truncate-remainder u8-ready? unquote
utf8->string vector vector->string vector-copy vector-fill!
vector-length vector-ref vector? with-exception-handler write-char
write-u8 string-fill! string-length string-ref string<=?
string=? string>? substring symbol=? syntax-error textual-port?
truncate-quotient truncate/ unless unquote-splicing values
vector->list vector-append vector-copy! vector-for-each vector-map
vector-set! when write-bytevector write-string zero?))
(defvar chicken-builtin-symbols
'(and-let* assume compiler-typecase cond-expand condition-case cut cute declare define-constant
define-inline define-interface define-record define-record-type define-specialization
define-syntax-rule define-type define-values dotimes ecase fluid-let foreign-lambda
foreign-lambda* foreign-primitive foreign-safe-lambda foreign-safe-lambda* functor
handle-exceptions import let*-values let-location let-optionals let-optionals*
let-values letrec* letrec-values match-letrec module parameterize regex-case
require-extension select set! unless use when with-input-from-pipe match
match-lambda match-lambda* match-let match-let* receive))
(defun chicken-load-symbols (module-list)
"Load symbols from Chicken.
Argument MODULE-LIST The modules to extract symbols from."
(let ((symbols))
(chicken-remove-error-module module-list)
(if (file-exists-p "~/.emacs.d/.chicken-scheme-symbols-dump.el")
(progn
(message "~/.emacs.d/.chicken-scheme-symbols-dump.el exist, load it.")
(load "~/.emacs.d/.chicken-scheme-symbols-dump.el"))
(dolist (module module-list)
(let* ((output (shell-command-to-string (format "csi -q -w -e \"(use %s)(display (map car (##sys#macro-environment)))(display (map car (##sys#current-environment)))\"" module)))
(cleaned (replace-regexp-in-string "[^ ]*[\]\[#.\(\),'`<>:]+[^ ]*" "" output)))
(setq symbols (concat cleaned " " symbols))
(message (format "Retrieved symbols from Chicken Module %s" module))))
(chicken-dump-vars-to-file '(symbols) "~/.emacs.d/.chicken-scheme-symbols-dump.el"))
(delete-dups (eval (read (concat "'(" symbols ")"))))))
(defvar ac-chicken-symbols-candidates-cache '())
(defun ac-chicken-symbols-candidates ()
"Use `chicken-ac-modules' to generate `auto-complete' candidates."
(if (or (equal nil ac-chicken-symbols-candidates-cache)
(not (equal chicken-ac-modules (car ac-chicken-symbols-candidates-cache))))
(setq ac-chicken-symbols-candidates-cache
`(,chicken-ac-modules
. ,(delq nil
(mapcar #'(lambda (s)
(condition-case err
(let ((n (symbol-name s)))
(cons n n))
(wrong-type-argument '())))
(chicken-load-symbols chicken-ac-modules))))))
(cdr (append ac-chicken-symbols-candidates-cache
(mapcar (lambda (s) (cons (symbol-name s) (symbol-name s))) chicken-builtin-symbols))))
(defun ac-r5rs-candidates ()
"Provides completion candidates for R5RS symbols"
(mapcar (lambda (s) (cons (symbol-name s) (symbol-name s))) r5rs-symbols))
(defun ac-r7rs-candidates ()
"Provides completion candidates for R7RS symbols"
(mapcar (lambda (s) (cons (symbol-name s) (symbol-name s))) r7rs-small-symbols))
(defun ac-chicken-doc (symbol-name)
"Use chicken-doc to recover documentation for a given symbol.
Argument SYMBOL-NAME The symbol to recover documentation for."
(shell-command-to-string (format "chicken-doc %s" (substring-no-properties symbol-name))))
(defconst chicken-scheme-font-lock-keywords '()
"Extended highlighting for Scheme modes using Chicken keywords.")
(defun chicken-load-font-lock-keywords ()
"Load chicken keywords into font-lock."
(interactive)
(setq font-lock-defaults
`((chicken-scheme-font-lock-keywords)
nil ; don't do strings and comments
nil ; don't do case sensitive
((,(replace-regexp-in-string (concat "[" chicken-prefix "]") "a" "+-*/.<>=!?$%_&~^:") . "w"))
beginning-of-defun
(font-lock-mark-block-function . mark-defun)
))
(if (equal nil chicken-scheme-font-lock-keywords)
(chicken-cache-font-lock-keywords)))
(defun chicken-cache-font-lock-keywords ()
"Cache font-lock keywords for Chicken."
(message "Caching Chicken font-lock-keywords")
(setq chicken-scheme-font-lock-keywords
(append '()
scheme-font-lock-keywords-1
scheme-font-lock-keywords-2
(eval-when-compile
(let* ((kw (sort (mapcar (lambda (p) (car p)) (append (ac-chicken-symbols-candidates) (ac-r5rs-candidates) (ac-r7rs-candidates))) 'string<))
(nkw (length kw))
(step 100))
(loop
with result = '()
for ptr from 0 by step
while (< ptr nkw)
do
(let ((window (last (butlast kw (- nkw (+ ptr step))) step)))
(setq result (append result
(list `(,(regexp-opt window 'words) (1 font-lock-builtin-face))))))
finally
return result))))))
(defvar ac-source-r5rs-symbols
'((candidates . ac-r5rs-candidates)
(candidate-face . ac-chicken-scheme-candidate-face)
(selection-face . ac-chicken-scheme-selection-face)
(symbol . "5")
(requires . 1)
(cache)))
(defvar ac-source-r7rs-symbols
'((candidates . ac-r7rs-candidates)
(candidate-face . ac-chicken-scheme-candidate-face)
(selection-face . ac-chicken-scheme-selection-face)
(symbol . "7")
(requires . 1)
(cache)))
(defvar ac-source-chicken-symbols
'((candidates . ac-chicken-symbols-candidates)
(candidate-face . ac-chicken-scheme-candidate-face)
(selection-face . ac-chicken-scheme-selection-face)
(symbol . "c")
(requires . 1)
(document . ac-chicken-doc)
(cache)))
(defvar ac-source-chicken-symbols-prefixed
`((candidates . ac-chicken-symbols-candidates)
(candidate-face . ac-chicken-scheme-candidate-face)
(selection-face . ac-chicken-scheme-selection-face)
(symbol . "c")
(requires . 1)
(document . ac-chicken-doc)
(prefix . ,(concat "[^ \t\r\n" chicken-prefix "]*[" chicken-prefix "]\\(.*\\)"))
(cache)))
(defun chicken-fix-font-lock ()
"Sets the font-lock for chicken keywords"
(interactive)
(chicken-load-font-lock-keywords))
(defun setup-chicken-scheme ()
"Hook for Chicken into scheme-mode."
(interactive)
(chicken-fix-font-lock)
(make-local-variable 'ac-sources)
(add-to-list 'ac-sources 'ac-source-chicken-symbols)
(add-to-list 'ac-sources 'ac-source-r5rs-symbols)
(add-to-list 'ac-sources 'ac-source-r7rs-symbols)
(add-to-list 'ac-sources 'ac-source-chicken-symbols-prefixed)
(message "Chicken Scheme ready."))
(defun chicken-show-help ()
"Show documentation for the symbol at the present point."
(interactive)
(message (ac-chicken-doc
(replace-regexp-in-string
(concat "[^" chicken-prefix "]*[" chicken-prefix "]+")
""
(symbol-name (symbol-at-point))))))
(provide 'chicken-scheme)
;;; chicken-scheme.el ends here