diff options
| -rw-r--r-- | README.org | 13 | ||||
| -rw-r--r-- | elisp/geiser-chicken.el | 30 | ||||
| -rw-r--r-- | scheme/chicken/geiser/chicken5.scm | 401 |
3 files changed, 431 insertions, 13 deletions
@@ -45,7 +45,18 @@ or byte-compiled and installed after performing the standard configure/make/make install dance. See the INSTALL file for more details. -** Chicken Addendum +** Chicken 5 Addendum + These steps are necessary to fully support Chicken Scheme, but are + not required for any other scheme. + + - Install the necessary support eggs: + +#+BEGIN_EXAMPLE + $ chicken-install -s apropos srfi-18 srfi-1 +#+END_EXAMPLE + + +** Chicken 4 Addendum These steps are necessary to fully support Chicken Scheme, but are not required for any other scheme. diff --git a/elisp/geiser-chicken.el b/elisp/geiser-chicken.el index 9f38354..dafdef9 100644 --- a/elisp/geiser-chicken.el +++ b/elisp/geiser-chicken.el @@ -109,12 +109,6 @@ this variable to t." :type 'integer :group 'geiser-chicken) -(geiser-custom--defcustom geiser-chicken-required-modules - (list "chicken-doc" "apropos" "data-structures" "extras" "ports" "posix" "srfi-1" "srfi-13" "srfi-14" "srfi-18" "srfi-69" "tcp" "utils") - "Modules automatically loaded in the Chicken REPL." - :type '(repeat string) - :group 'geiser-chicken) - ;;; REPL support: @@ -133,9 +127,7 @@ This function uses `geiser-chicken-init-file' if it exists." ,@n-flags "-include-path" ,(expand-file-name "chicken/" geiser-scheme-dir) ,@(apply 'append (mapcar (lambda (p) (list "-include-path" p)) geiser-chicken-load-path)) - ,@(and init-file (file-readable-p init-file) (list init-file)) - ,@(apply 'append (mapcar (lambda (m) (list "-R" m)) - geiser-chicken-required-modules))))) + ,@(and init-file (file-readable-p init-file) (list init-file))))) (defconst geiser-chicken--prompt-regexp "#[^;]*;[^:0-9]*:?[0-9]+> ") @@ -266,14 +258,17 @@ This function uses `geiser-chicken-init-file' if it exists." (defconst geiser-chicken-minimum-version "4.8.0.0") (defun geiser-chicken--version (binary) - (car (process-lines binary "-e" "(display (chicken-version))"))) + (cadr + (split-string + (cadddr + (process-lines "csc" "-version"))))) (defun connect-to-chicken () "Start a Chicken REPL connected to a remote process." (interactive) (geiser-connect 'chicken)) -(defun geiser-chicken--compile-or-load (force-load) +(defun geiser-chicken4--compile-or-load (force-load) (let ((target (expand-file-name "chicken/geiser/emacs.so" geiser-scheme-dir)) (source @@ -295,9 +290,20 @@ This function uses `geiser-chicken-init-file' if it exists." suppression-prefix source target suppression-postfix))))) (geiser-eval--send/wait load-sequence)))) +(defun geiser-chicken5-load () + (let ((source (expand-file-name "chicken/geiser/chicken5.scm" geiser-scheme-dir)) + (suppression-prefix + "(define geiser-stdout (current-output-port))(current-output-port (make-output-port (lambda a #f) (lambda a #f)))") + (suppression-postfix + "(current-output-port geiser-stdout)")) + (geiser-eval--send/wait (format "%s (load \"%s\") (import geiser) %s" suppression-prefix source suppression-postfix)))) + (defun geiser-chicken--startup (remote) (compilation-setup t) - (geiser-chicken--compile-or-load t)) + (cond + ((version< (geiser-chicken--version nil) "5.0.0") + (geiser-chicken4--compile-or-load t)) + (t (geiser-chicken5-load)))) ;;; Implementation definition: diff --git a/scheme/chicken/geiser/chicken5.scm b/scheme/chicken/geiser/chicken5.scm new file mode 100644 index 0000000..f5f0c30 --- /dev/null +++ b/scheme/chicken/geiser/chicken5.scm @@ -0,0 +1,401 @@ +;; -*- geiser-scheme-implementation: 'chicken + +;; Copyright (C) 2018 Daniel J Leslie + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the Modified BSD License. You should +;; have received a copy of the license along with this program. If +;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. + +(module geiser + (geiser-eval + geiser-no-values + geiser-newline + geiser-start-server + geiser-completions + geiser-autodoc + geiser-object-signature + geiser-symbol-location + geiser-symbol-documentation + geiser-find-file + geiser-add-to-load-path + geiser-load-file + geiser-compile-file + geiser-compile + geiser-module-exports + geiser-module-path + geiser-module-location + geiser-module-completions + geiser-macroexpand + geiser-chicken-use-debug-log + geiser-chicken-load-paths) + + (import + scheme + apropos + srfi-1 + srfi-18 + (chicken base) + (chicken tcp) + (chicken file) + (chicken file posix) + (chicken format) + (chicken condition) + (chicken port) + (chicken string) + (chicken repl) + (chicken syntax)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Utilities + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define geiser-chicken-use-debug-log (make-parameter #f)) + + (define empty-symbol (string->symbol "")) + + (define (symbol-information-list partial-string) + (map (lambda (lst) + (let* ((module (if (eq? empty-symbol (caar lst)) #f (caar lst))) + (name (cdar lst))) + (append (list name module) (cdr lst)))) + (apropos-information-list partial-string #:macros? #t))) + + (define debug-log (make-parameter #f)) + (define (write-to-log form) + (when (geiser-chicken-use-debug-log) + (when (not (debug-log)) + (debug-log (file-open "geiser.log" (+ open/wronly open/append open/text open/creat))) + (set-file-position! (debug-log) 0 seek/end)) + (file-write (debug-log) (with-all-output-to-string (lambda () (write form) (newline)))) + (file-write (debug-log) "\n"))) + + (define (string-has-prefix? s prefix) + (cond + ((= 0 (string-length prefix)) #t) + ((= 0 (string-length s)) #f) + ((eq? (string-ref s 0) (string-ref prefix 0)) + (string-has-prefix? (substring s 1) (substring prefix 1))) + (else #f))) + + ;; This really should be a chicken library function + (define (write-exception exn) + (define (write-call-entry call) + (let ((type (vector-ref call 0)) + (line (vector-ref call 1))) + (cond + ((equal? type "<syntax>") + (display (string-append type " ")) (write line) (newline)) + ((equal? type "<eval>") + (display (string-append type " ")) (write line) (newline))))) + + (display (format "Error: (~s) ~s: ~s" + ((condition-property-accessor 'exn 'location) exn) + ((condition-property-accessor 'exn 'message) exn) + ((condition-property-accessor 'exn 'arguments) exn))) + (newline) + (display "Call history: ") (newline) + (map write-call-entry ((condition-property-accessor 'exn 'call-chain) exn)) + (newline)) + + ;; And this should be a chicken library function as well + (define (with-all-output-to-string thunk) + (with-output-to-string + (lambda () + (with-error-output-to-port + (current-output-port) + thunk)))) + + (define (maybe-call func val) + (if val (func val) #f)) + + ;; Wraps output from geiser functions + (define (call-with-result module thunk) + (let* ((result (if #f #f)) + (output (if #f #f))) + + (set! output + (handle-exceptions exn + (with-all-output-to-string + (lambda () (write-exception exn))) + (with-all-output-to-string + (lambda () + (call-with-values thunk (lambda v (set! result v))))))) + + (set! result + (cond + ((list? result) + (map (lambda (v) (with-output-to-string (lambda () (write v)))) result)) + ((eq? result (if #f #t)) + (list output)) + (else + (list (with-output-to-string (lambda () (write result))))))) + + (let ((out-form + `((result ,@result) + (output . ,output)))) + (write out-form) + (write-to-log '[[RESPONSE]]) + (write-to-log out-form)) + + (newline))) + + (define (read* str) + (with-input-from-string str (lambda () (read)))) + + (define (eval* str) + (cond + ((symbol? str) (eval str)) + ((string? str) (eval (read* str))) + (else #f))) + + (define (fmt node) + (let* ((mod (cadr node)) + (sym (car node)) + (rest (cddr node)) + (type (if (or (list? rest) (pair? rest)) (car rest) rest))) + (cond + ((equal? 'macro type) + `(,sym ("args" (("required" <macro>) + ("optional" ...) + ("key"))) + ("module"))) + ((or (equal? 'variable type) + (equal? 'constant type)) + `(,sym ("value" . ,(eval* sym)))) + (else + (let ((reqs '()) + (opts '()) + (keys '()) + (args (if (or (list? rest) (pair? rest)) (cdr rest) '()))) + + (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f)) + (when (not (null? args)) + (cond + ((or (pair? args) (list? args)) + (cond + ((eq? '#!key (car args)) + (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t)) + ((eq? '#!optional (car args)) + (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f)) + (else + (begin + (cond + (reqs? + (set! reqs (append reqs (list (car args))))) + (opts? + (set! opts (append opts (list (cons (caar args) (cdar args)))))) + (keys? + (set! keys (append keys (list (cons (caar args) (cdar args))))))) + (collect-args (cdr args)))))) + (else + (set! opts (list args '...)))))) + + (collect-args args) + + `(,sym ("args" (("required" ,@reqs) + ("optional" ,@opts) + ("key" ,@keys))) + ("module"))))))) + + ;; Builds a signature list from an identifier + (define (find-signatures sym) + (let ((result (symbol-information-list sym))) + (map fmt result))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Geiser core functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Basically all non-core functions pass through geiser-eval + + (define (form-has-safe-geiser? form) + (any (cut eq? (car form) <>) + '(geiser-no-values geiser-newline geiser-completions + geiser-autodoc geiser-object-signature geiser-symbol-location + geiser-symbol-documentation geiser-module-exports + geiser-module-path geiser-module-location + geiser-module-completions geiser-chicken-use-debug-log))) + + (define (form-has-any-geiser? form) + (string-has-prefix? (->string (car form)) "geiser-")) + + (define (form-defines-any-module? form) + (or + ;; Geiser seems to send buffers as (begin ..buffer contents..) + (and (eq? (car form) 'begin) + (form-defines-any-module? (cadr form))) + (any (cut eq? (car form) <>) + '(module define-library)))) + + (define (geiser-eval module form . rest) + (when (and module (not (symbol? module))) + (error "Module should be a symbol")) + + ;; All calls start at toplevel + (let* ((is-safe-geiser? (form-has-safe-geiser? form)) + (host-module (and (not is-safe-geiser?) + (not (form-has-any-geiser? form)) + (not (form-defines-any-module? form)) + module)) + (thunk (lambda () (eval form)))) + + (write-to-log `[[REQUEST host-module: ,host-module]]) + (write-to-log form) + + (if is-safe-geiser? + (call-with-result #f thunk) + (call-with-result host-module thunk)))) + + ;; Load a file + + (define (geiser-load-file file) + (let* ((file (if (symbol? file) (symbol->string file) file)) + (found-file (geiser-find-file file))) + (call-with-result #f + (lambda () + (when found-file + (load found-file)))))) + + ;; The no-values identity + + (define (geiser-no-values) + (values)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Miscellaneous +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Invoke a newline + + (define (geiser-newline . rest) + (newline)) + + ;; Spawn a server for remote repl access + + (define (geiser-start-server . rest) + (let* ((listener (tcp-listen 0)) + (port (tcp-listener-port listener))) + (define (remote-repl) + (receive (in out) (tcp-accept listener) + (current-input-port in) + (current-output-port out) + (current-error-port out) + + (repl))) + + (thread-start! (make-thread remote-repl)) + + (write-to-log `(geiser-start-server . ,rest)) + (write-to-log `(port ,port)) + + (write `(port ,port)) + (newline))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Completions, Autodoc and Signature +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (geiser-completions prefix . rest) + (let ((prefix (->string prefix))) + (filter (cut string-has-prefix? <> prefix) + (map ->string (map car (symbol-information-list prefix)))))) + + (define (geiser-module-completions prefix . rest) + '()) + + (define (geiser-autodoc ids . rest) + (cond + ((null? ids) '()) + ((not (list? ids)) + (geiser-autodoc (list ids))) + (else + (let ((details (find-signatures (car ids)))) + (if (null? details) + (geiser-autodoc (cdr ids)) + details))))) + + (define (geiser-object-signature name object . rest) + (let* ((sig (geiser-autodoc `(,name)))) + (if (null? sig) '() (car sig)))) + + ;; TODO: Divine some way to support this functionality + + (define (geiser-symbol-location symbol . rest) + '(("file") ("line"))) + + (define (geiser-symbol-documentation symbol . rest) + (let* ((sig (find-signatures symbol))) + `(("signature" ,@(car sig)) + ("docstring" . "")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; File and Buffer Operations +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define geiser-chicken-load-paths (make-parameter '("" "."))) + + (define (geiser-find-file file . rest) + (when file + (let ((paths (geiser-chicken-load-paths))) + (define (try-find file paths) + (cond + ((null? paths) #f) + ((file-exists? (string-append (car paths) file)) + (string-append (car paths) file)) + (else (try-find file (cdr paths))))) + (try-find file paths)))) + + (define (geiser-add-to-load-path directory . rest) + (let* ((directory (if (symbol? directory) + (symbol->string directory) + directory)) + (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory))))) + (string-append directory "/") + directory))) + (call-with-result #f + (lambda () + (when (directory-exists? directory) + (geiser-chicken-load-paths (cons directory (geiser-chicken-load-paths)))))))) + + (define (geiser-compile-file file . rest) + #f) + + ;; TODO: Support compiling regions + + (define (geiser-compile form module . rest) + (error "Chicken does not support compiling regions")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Modules +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Should return: + ;; '(("modules" . sub-modules) ("procs" . procedures) ("syntax" . macros) ("vars" . variables)) + (define (geiser-module-exports module-name . rest) + '()) + + ;; Returns the path for the file in which an egg or module was defined + + (define (geiser-module-path module-name . rest) + #f) + + ;; Returns: + ;; `(("file" . ,(module-path name)) ("line")) + + (define (geiser-module-location name . rest) + #f) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Misc +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (geiser-macroexpand form . rest) + (with-output-to-string + (lambda () + (write (expand form))))) + +;; End module + ) |