;;; chicken-scheme.el --- Scheme-mode extensions for Chicken Scheme ;; ;; Copyright 2014 Daniel Leslie ;; Author: Daniel Leslie ;; 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-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? 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-copy string-fill! string-length string-ref string-set! 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? 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? 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