282 lines
9.7 KiB
Scheme
282 lines
9.7 KiB
Scheme
;;;; 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)
|
|
;; was string-prefix?, now defaults to case-insensitive
|
|
;; (MIT/GNU Scheme's default)
|
|
(if (and (string-prefix-ci? prefix (symbol-name symbol))
|
|
(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))))
|