diff options
Diffstat (limited to 'scheme/mit/geiser')
| -rw-r--r-- | scheme/mit/geiser/compile.scm | 9 | ||||
| -rw-r--r-- | scheme/mit/geiser/emacs.scm | 252 | ||||
| -rw-r--r-- | scheme/mit/geiser/geiser.pkg | 20 | ||||
| -rw-r--r-- | scheme/mit/geiser/load.scm | 11 |
4 files changed, 292 insertions, 0 deletions
diff --git a/scheme/mit/geiser/compile.scm b/scheme/mit/geiser/compile.scm new file mode 100644 index 0000000..5817aa2 --- /dev/null +++ b/scheme/mit/geiser/compile.scm @@ -0,0 +1,9 @@ +(declare (usual-integrations)) + +(load-option 'CREF) + +(with-working-directory-pathname + (directory-pathname (current-load-pathname)) + (lambda () + (cf "emacs") + (cref/generate-constructors "geiser" 'ALL))) diff --git a/scheme/mit/geiser/emacs.scm b/scheme/mit/geiser/emacs.scm new file mode 100644 index 0000000..d94c105 --- /dev/null +++ b/scheme/mit/geiser/emacs.scm @@ -0,0 +1,252 @@ +;;;; package: (runtime geiser) +(declare (usual-integrations)) + +(load-option 'format) + +(define (all-completions prefix environment) + (let (;; (prefix + ;; (if (environment-lookup environment 'PARAM:PARSER-CANONICALIZE-SYMBOLS?) + ;; (string-downcase prefix) + ;; prefix)) + (completions '())) + (for-each-interned-symbol + (lambda (symbol) + (if (and (string-prefix-ci? prefix (symbol-name symbol)) ; was string-prefix?, now defaults to case-insensitive (MIT/GNU Scheme's default) + (environment-bound? environment symbol)) + (set! completions (cons (symbol-name symbol) completions))) + unspecific)) + completions)) + +(define (operator-arglist symbol env) + (let ((type (environment-reference-type env symbol))) + (let ((ans (if (eq? type 'normal) + (let ((binding (environment-lookup env symbol))) + (if (and binding + (procedure? binding)) + (cons symbol (read-from-string (string-trim (with-output-to-string + (lambda () (pa binding)))))) + #f)) + #f ;; macros + ))) + ans))) + +(define (geiser:operator-arglist symbol env) + (let* ((arglist (operator-arglist symbol env)) + (operator symbol)) + (if arglist + (let loop ((arglist (cdr arglist)) + (optionals? #f) + (required '()) + (optional '())) + (cond ((null? arglist) + `(,operator ("args" (("required" ,@(reverse required)) ("optional" ,@(reverse optional)) ("key"))))) ;; ("module" ,module) + ((symbol? arglist) + (loop '() + #t + required + (cons "..." (cons arglist optional)))) + ((eq? (car arglist) #!optional) + (loop (cdr arglist) + #t + required + optional)) + (else + (loop + (cdr arglist) + optionals? + (if optionals? required (cons (car arglist) required)) + (if optionals? (cons (car arglist) optional) optional))))) + '()))) + + +(define (read-from-string str) + (with-input-from-string str + read)) + +(define (all-packages) + (let loop ((package (name->package '()))) ;; system-global-package + (cons package + (append-map loop (package/children package))))) + +(define anonymous-package-prefix + "environment-") + +(define (env->pstring env) + (let ((package (environment->package env))) + (if package + (write-to-string (package/name package)) + (string anonymous-package-prefix (object-hash env))))) + +(define geiser-repl (nearest-repl)) + +(define (set-geiser-repl-prompt! env) + (set-repl/prompt! geiser-repl (format #f "~s =>" (package/name (environment->package env)))) + env) + +(define geiser-env #f) + +(define (get-symbol-definition-location object) + (let ((file (cond ((and (entity? object) + (procedure? object)) + (receive (a b) + (compiled-entry/filename-and-index (entity-procedure object)) + b + a)) + ((compiled-procedure? object) + (receive (a b) + (compiled-entry/filename-and-index object) + b + a)) + (else + '())))) + (fix-mit-source-dir + (if (and (string? file) + (string-suffix? ".inf" file)) + (string-append (substring file 0 (- (string-length file) 3)) "scm") + file)))) + +(define (fix-mit-source-dir filename) + (let ((default-location "/usr/lib/mit-scheme-x86-64/")) + (if (and geiser:mit-scheme-source-directory + (not (string-null? geiser:mit-scheme-source-directory))) + (if (string-prefix? default-location filename) + (string-append geiser:mit-scheme-source-directory (substring filename (string-length default-location) (string-length filename))) + filename) + filename))) + +(define geiser:mit-scheme-source-directory #f) + +;;;; *************************************************************************** + +(define (geiser:eval module form . rest) + rest + (let* ((output (open-output-string)) + (environment (package/environment (find-package (if module module '(user)) #t))) + (result (with-output-to-port output + (lambda () + (eval form environment))))) + (write `((result ,(write-to-string result)) (output . ,(get-output-string output)))))) + +(define (geiser:autodoc ids . rest) + rest + (cond ((null? ids) '()) + ((not (list? ids)) + (geiser:autodoc (list ids))) + ((not (symbol? (car ids))) + (geiser:autodoc (cdr ids))) + (else + (let ((details (map (lambda (id) (geiser:operator-arglist id (->environment '(user)))) ids))) + details)))) + +(define (geiser:module-completions prefix . rest) + rest + (filter (lambda (pstring) + (substring? prefix (write-to-string pstring))) + (map (lambda (package) (env->pstring (package/environment package))) (all-packages)))) + +(define (geiser:completions prefix . rest) + rest + (sort (all-completions prefix (->environment '(user))) + string<?)) + +(define (geiser:ge environment) + (let ((env (package/environment (find-package environment #t)))) + (set-geiser-repl-prompt! env) + (set! geiser-env env)) + (ge environment)) + +(define (geiser:load-file filename) + (load filename)) + +(define (geiser:module-exports module) + (let* ((pkg (find-package module #t)) + (children (map package/name (package/children pkg))) + (env (package/environment pkg))) + (let loop ((vars '()) + (procs '()) + (syntax '()) + (bindings (environment-bindings env))) + (if (null? bindings) + `(("vars" . ,vars) ("procs" . ,procs) ("syntax" . ,syntax) ("modules" . ,(map list children))) + (let* ((binding (car bindings)) + (name (car binding)) + (value (if (null? (cdr binding)) 'unassigned (cadr binding))) + (ref-type (environment-reference-type env name))) + (cond ((eq? 'macro ref-type) + (loop vars + procs + (cons `(,name ("signature")) syntax) + (cdr bindings))) + ((procedure? value) + (loop vars + (cons `(,name ("signature" . ,(geiser:operator-arglist name env))) procs) + syntax + (cdr bindings))) + (else + (loop (cons `(,name) vars) + procs + syntax + (cdr bindings))))))))) + +(define (geiser:symbol-documentation symbol) + (if (environment-bound? geiser-env symbol) + (let ((ref-type (environment-reference-type geiser-env symbol)) + (value (environment-safe-lookup geiser-env symbol))) + (case ref-type + ((macro) + `(("signature" ,symbol ("args")) + ("docstring" . "Macro"))) + ((unassigned) + `(("signature" ,symbol ("args")) + ("docstring" . "Value: Unassigned~%"))) + ((normal) + (if (procedure? value) + (let ((signature (geiser:operator-arglist symbol geiser-env))) + `(("signature" . ,signature) + ("docstring" . ,(format #f "Procedure:~%~a~%" (with-output-to-string (lambda () (pp value))))))) + `(("signature" ,symbol ("args")) + ("docstring" . ,(format #f "Value:~%~a~%" (with-output-to-string (lambda () (pp value)))))) + )) + (else + `(("signature" ,symbol ("args")) + ("docstring" . "Unknown thing..."))))) + '())) + +(define (geiser:symbol-location symbol) + (if (environment-bound? geiser-env symbol) + (let ((ref-type (environment-reference-type geiser-env symbol)) + (value (environment-safe-lookup geiser-env symbol))) + (if (eq? ref-type 'normal) + (let ((file (get-symbol-definition-location value))) + `(("name" . ,symbol) + ("file" . ,file) + ("line"))) + '())) + `(("name" . ,symbol) + ("file") + ("line")))) + +(define (geiser:module-location symbol) + `(("name" . ,symbol) + ("file") + ("line"))) + + +(define (geiser:newline) + #f) + +(define (geiser:no-values) + #f) + +(define (geiser:set-mit-scheme-source-directory dir) + (set! geiser:mit-scheme-source-directory dir)) + +(define (geiser:callers symbol) + symbol + #f) + +(define (geiser:callees symbol) + symbol + #f) + +(set-geiser-repl-prompt! (package/environment (find-package '(user)))) diff --git a/scheme/mit/geiser/geiser.pkg b/scheme/mit/geiser/geiser.pkg new file mode 100644 index 0000000..7f67343 --- /dev/null +++ b/scheme/mit/geiser/geiser.pkg @@ -0,0 +1,20 @@ +;; -*-Scheme-*- +(define-package (runtime geiser) + (files "emacs") + (parent ()) + (export () + geiser:eval + geiser:autodoc + geiser:module-completions + geiser:completions + geiser:ge + geiser:load-file + geiser:module-exports + geiser:symbol-documentation + geiser:symbol-location + geiser:module-location + geiser:callers + geiser:callees + geiser:set-mit-scheme-source-directory + geiser:newline + geiser:no-values)) diff --git a/scheme/mit/geiser/load.scm b/scheme/mit/geiser/load.scm new file mode 100644 index 0000000..2dffd59 --- /dev/null +++ b/scheme/mit/geiser/load.scm @@ -0,0 +1,11 @@ +(declare (usual-integrations)) + +(with-working-directory-pathname + (directory-pathname (current-load-pathname)) + (lambda () + (load "compile.scm") + (load-package-set "geiser" + `()))) + +(add-subsystem-identification! "Geiser" '(0 1)) + |