summaryrefslogtreecommitdiff
path: root/scheme
diff options
context:
space:
mode:
Diffstat (limited to 'scheme')
-rw-r--r--scheme/chicken/geiser/emacs.scm456
1 files changed, 210 insertions, 246 deletions
diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm
index 0975bf0..401eb90 100644
--- a/scheme/chicken/geiser/emacs.scm
+++ b/scheme/chicken/geiser/emacs.scm
@@ -6,7 +6,6 @@
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
(module geiser
- ;; A bunch of these needn't be toplevel functions
(geiser-eval
geiser-no-values
geiser-newline
@@ -26,31 +25,25 @@
geiser-module-location
geiser-module-completions
geiser-macroexpand
- make-geiser-toplevel-bindings)
-
- ;; Necessary built in units
- (import chicken
- scheme
- extras
- data-structures
- ports
- csi
- irregex
- srfi-1
- posix
- utils)
-
- (use apropos
- regex
- chicken-doc
- tcp
- srfi-18)
-
- (define use-debug-log #f)
-
- (if use-debug-log
- (use posix))
-
+ geiser-use-debug-log)
+
+ (import chicken scheme)
+ (use
+ apropos
+ chicken-doc
+ data-structures
+ extras
+ ports
+ posix
+ srfi-1
+ srfi-13
+ srfi-14
+ srfi-18
+ srfi-69
+ tcp
+ utils)
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Symbol lists
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -212,29 +205,53 @@
u32vector-ref u32vector-set! u8vector->blob u8vector->blob/shared
u8vector-length u8vector-ref u8vector-set! unless void when write-char
zero?)))
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (define geiser-use-debug-log (make-parameter #f))
+
(define find-module ##sys#find-module)
(define current-module ##sys#current-module)
(define switch-module ##sys#switch-module)
(define module-name ##sys#module-name)
(define (list-modules) (map car ##sys#module-table))
- (define (write-to-log form) #f)
- (define debug-log (make-parameter #f))
-
- (if use-debug-log
- (begin
- (define (write-to-log form)
- (when (not (debug-log))
- (debug-log (file-open "~/geiser-log.txt" (+ 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 memo (make-parameter (make-hash-table)))
+ (define (clear-memo) (hash-table-clear! (memo)))
+ (define (memoize tag thunk)
+ (let ((table (memo)))
+ (if (hash-table-exists? table tag)
+ (hash-table-ref table tag)
+ (begin
+ (hash-table-set! table tag (thunk))
+ (memoize tag thunk)))))
+ (define debug-log (make-parameter #f))
+ (define (write-to-log form)
+ (when (geiser-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 (remove-internal-name-mangling sym)
+ (let* ((sym (->string sym))
+ (octothorpe-index (string-index-right sym #\#)))
+ (if octothorpe-index
+ (values (substring/shared sym (add1 octothorpe-index))
+ (substring/shared sym 0 octothorpe-index))
+ (values sym '()))))
+
+ (define (string-has-prefix? s prefix)
+ (let ((s-length (string-length s))
+ (prefix-length (string-length prefix)))
+ (and
+ (< prefix-length s-length)
+ (string-contains s prefix 0 prefix-length))))
+
;; This really should be a chicken library function
(define (write-exception exn)
(define (write-call-entry call)
@@ -266,19 +283,6 @@
(define (maybe-call func val)
(if val (func val) #f))
- (define (make-apropos-regex prefix)
- (string-append "^([^#]+#)*" (regexp-escape prefix)))
-
- (define (describe-symbol sym #!key (exact? #f))
- (let* ((str (->string sym))
- (found (apropos-information-list (regexp (make-apropos-regex str)) #:macros? #t)))
- (delete-duplicates
- (if exact?
- (filter (lambda (v)
- (equal? str (string-substitute ".*#([^#]+)" "\\1" (symbol->string (car v)))))
- found)
- found))))
-
;; Wraps output from geiser functions
(define (call-with-result module thunk)
(let* ((result (if #f #f))
@@ -300,42 +304,21 @@
(set! result
(cond
((list? result)
- (map (lambda (v) (with-output-to-string (lambda () (pretty-print v)))) 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 () (pretty-print result)))))))
+ (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 geiser-toplevel-functions (make-parameter '()))
-
- ;; This macro aids in the creation of toplevel definitions for the interpreter which are also available to code
- ;; toplevel passes parameters via the current-input-port, and so in order to make the definition behave nicely
- ;; in both usage contexts I defined a (get-arg) function which iteratively pulls arguments either from the
- ;; input port or from the variable arguments, depending on context.
- (define-syntax define-toplevel-for-geiser
- (lambda (f r c)
- (let* ((name (cadr f))
- (body (cddr f)))
- `(begin
- (,(r 'define) (,name . !!args)
- (,(r 'define) !!read-arg (null? !!args))
- (,(r 'define) (get-arg)
- (if !!read-arg
- (read)
- (let ((arg (car !!args)))
- (set! !!args (cdr !!args))
- arg)))
- (begin ,@body))
- (,(r 'geiser-toplevel-functions) (cons (cons ',name ,name) (geiser-toplevel-functions)))))))
-
(define (find-standards-with-symbol sym)
(append
(if (any (cut eq? <> sym) (geiser-r4rs-symbols))
@@ -381,89 +364,89 @@
(any (cut eq? type <>) types)))
(match-nodes sym)))))
+ (define (make-module-list sym module-sym)
+ (if (null? module-sym)
+ (find-standards-with-symbol sym)
+ (cons module-sym (find-standards-with-symbol sym))))
+
+ (define (fmt sym node)
+ (let* ((entry-str (car node))
+ (module (cadr node))
+ (rest (cddr node))
+ (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
+ (cond
+ ((equal? 'macro type)
+ `(,entry-str ("args" (("required" <macro>)
+ ("optional" ...)
+ ("key")))
+ ("module" ,@(make-module-list sym module))))
+ ((or (equal? 'variable type)
+ (equal? 'constant type))
+ (if (null? module)
+ `(,entry-str ("value" . ,(eval sym)))
+ (let* ((original-module (current-module))
+ (desired-module (find-module (string->symbol module)))
+ (value (begin (switch-module desired-module)
+ (eval sym))))
+ (switch-module original-module)
+ `(,entry-str ("value" . ,value)
+ ("module" ,@(make-module-list sym module))))))
+ (else
+ (let ((reqs '())
+ (opts '())
+ (keys '())
+ (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
+
+ (define (clean-arg arg)
+ (let ((s (->string arg)))
+ (substring/shared s 0 (string-skip-right s char-set:digit))))
+
+ (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 (clean-arg (car args))))))
+ (opts?
+ (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
+ (keys?
+ (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
+ (collect-args (cdr args))))))
+ (else
+ (set! opts (list (clean-arg args) '...))))))
+
+ (collect-args args)
+
+ `(,entry-str ("args" (("required" ,@reqs)
+ ("optional" ,@opts)
+ ("key" ,@keys)))
+ ("module" ,@(make-module-list sym module))))))))
+
;; Builds a signature list from an identifier
- (define (find-signatures toplevel-module sym)
- (define str (->string sym))
-
- (define (make-module-list sym module-sym)
- (if (null? module-sym)
- (find-standards-with-symbol sym)
- (cons module-sym (find-standards-with-symbol sym))))
-
- (define (fmt node)
- (let* ((entry-str (car node))
- (module (cadr node))
- (rest (cddr node))
- (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
- (cond
- ((equal? 'macro type)
- `(,entry-str ("args" (("required" <macro>)
- ("optional" ...)
- ("key")))
- ("module" ,@(make-module-list sym module))))
- ((or (equal? 'variable type)
- (equal? 'constant type))
- (if (null? module)
- `(,entry-str ("value" . ,(eval sym)))
- (let* ((original-module (current-module))
- (desired-module (find-module (string->symbol module)))
- (value (begin (switch-module desired-module)
- (eval sym))))
- (switch-module original-module)
- `(,entry-str ("value" . ,value)
- ("module" ,@(make-module-list sym module))))))
- (else
- (let ((reqs '())
- (opts '())
- (keys '())
- (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
-
- (define (clean-arg arg)
- (string->symbol (string-substitute "(.*[^0-9]+)[0-9]+" "\\1" (->string arg))))
-
- (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 (clean-arg (car args))))))
- (opts?
- (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
- (keys?
- (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
- (collect-args (cdr args))))))
- (else
- (set! opts (list (clean-arg args) '...))))))
-
- (collect-args args)
-
- `(,entry-str ("args" (("required" ,@reqs)
- ("optional" ,@opts)
- ("key" ,@keys)))
- ("module" ,@(make-module-list sym module))))))))
-
- (define (find sym)
+ (define (find-signatures sym)
+ (let ((str (->string sym)))
(map
- (lambda (s)
- ;; Remove egg name and add module
- (let* ((str (symbol->string (car s)))
- (name (string-substitute ".*#([^#]+)" "\\1" str))
- (module
- (if (string-search "#" str)
- (string-substitute "^([^#]+)#[^#]+$" "\\1" str)
- '())))
- (cons name (cons module (cdr s)))))
- (describe-symbol sym exact?: #t)))
-
- (map fmt (find sym)))
+ (cut fmt sym <>)
+ (filter
+ (lambda (v)
+ (eq? (car v) sym))
+ (map
+ (lambda (s)
+ ;; Remove egg name and add module
+ (let-values
+ (((name module) (remove-internal-name-mangling (car s))))
+ (cons (string->symbol name)
+ (cons (if (string? module) (string->symbol module) module)
+ (cdr s)))))
+ (apropos-information-list sym #:macros? #t))))))
;; Builds the documentation from Chicken Doc for a specific symbol
(define (make-doc symbol #!optional (filter-for-type #f))
@@ -478,64 +461,52 @@
(or (not filter-for-type)
(eq? (node-type n) filter-for-type)))
(match-nodes symbol))))))
-
- (define (make-geiser-toplevel-bindings)
- (map
- (lambda (pair)
- (toplevel-command (car pair) (cdr pair)))
- (geiser-toplevel-functions)))
-
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Geiser toplevel functions
+;; Geiser core functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Basically all non-core functions pass through geiser-eval
- (define-toplevel-for-geiser geiser-eval
+ (define (geiser-eval module form . rest)
;; We can't allow nested module definitions in Chicken
(define (form-has-module? form)
- (let ((reg "\\( *module +|\\( *define-library +"))
- (string-search reg form)))
-
- ;; Chicken doesn't support calling toplevel functions through eval,
- ;; So when we're in a module or calling into an environment we have
- ;; to first call from the toplevel environment and then switch
- ;; into the desired env.
- (define (form-has-geiser? form)
- (let ((reg "\\( *geiser-"))
- (string-search reg form)))
+ (or (eq? (car form) 'module) (eq? (car form) 'define-library)))
+
+ (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-find-file geiser-add-to-load-path
+ geiser-module-exports geiser-module-path geiser-module-location
+ geiser-module-completions geiser-use-debug-log)))
+
+ (when (and module
+ (not (symbol? module)))
+ (error "Module should be a symbol"))
;; All calls start at toplevel
- (let* ((module (get-arg))
- (form (get-arg))
- (str-form (format "~s" form))
- (is-module? (form-has-module? str-form))
- (is-geiser? (form-has-geiser? str-form))
+ (let* ((is-module? (form-has-module? form))
+ (is-safe-geiser? (form-has-safe-geiser? form))
(host-module (and (not is-module?)
- (not is-geiser?)
(any (cut equal? module <>) (list-modules))
- module)))
-
- (when (and module (not (symbol? module)))
- (error "Module should be a symbol"))
-
- ;; Inject the desired module as the first parameter
- (when is-geiser?
- (let ((module (maybe-call (lambda (v) (symbol->string module)) module)))
- (set! form (cons (car form) (cons module (cdr form))))))
-
- (define (thunk)
- (eval form))
+ module))
+ (thunk (lambda () (eval form))))
+ (write-to-log `[[REQUEST host-module ,host-module is-safe-geiser? ,is-safe-geiser?]])
(write-to-log form)
- (call-with-result host-module thunk)))
+ (if is-safe-geiser?
+ (call-with-result host-module (lambda () (memoize form thunk)))
+ (begin
+ (clear-memo)
+ (call-with-result host-module thunk)))))
;; Load a file
- (define-toplevel-for-geiser geiser-load-file
- (let* ((file (get-arg))
- (file (if (symbol? file) (symbol->string file) file))
+ (define (geiser-load-file file)
+ (let* ((file (if (symbol? file) (symbol->string file) file))
(found-file (geiser-find-file #f file)))
(call-with-result #f
(lambda ()
@@ -544,9 +515,9 @@
;; The no-values identity
- (define-toplevel-for-geiser geiser-no-values
+ (define (geiser-no-values)
(values))
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -576,57 +547,53 @@
(write `(port ,port))
(newline)))
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Completions, Autodoc and Signature
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define (geiser-completions toplevel-module prefix . rest)
- ;; We search both toplevel definitions and module definitions
- (let* ((prefix (if (symbol? prefix) (symbol->string prefix) prefix))
- (re (regexp (make-apropos-regex prefix))))
- (sort! (map (lambda (sym)
- ;; Strip out everything before the prefix
- (string-substitute (string-append ".*(" (regexp-escape prefix) ".*)") "\\1" (symbol->string sym)))
- (append (apropos-list re #:macros? #t)
- (geiser-module-completions toplevel-module prefix)))
- string<?)))
-
- (define (geiser-module-completions toplevel-module prefix . rest)
- (let* ((match (string-append "^" (regexp-escape prefix))))
- (filter (lambda (v) (string-search match (symbol->string v)))
- (list-modules))))
-
- (define (geiser-autodoc toplevel-module ids . rest)
- (define (generate-details sym)
- (find-signatures toplevel-module sym))
-
- (if (list? ids)
- (foldr append '()
- (map generate-details ids))
- '()))
-
- (define (geiser-object-signature toplevel-module name object . rest)
- (let* ((sig (geiser-autodoc toplevel-module `(,name))))
+ (define (geiser-completions prefix . rest)
+ (let ((prefix (->string prefix))
+ (unfiltered (map remove-internal-name-mangling
+ (apropos-list prefix #:macros? #t))))
+ (filter (cut string-has-prefix? <> prefix) unfiltered)))
+
+ (define (geiser-module-completions prefix . rest)
+ (let ((prefix (->string prefix)))
+ (filter (cut string-has-prefix? <> prefix) (map ->string (list-modules)))))
+
+ (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 toplevel-module symbol . rest)
+ (define (geiser-symbol-location symbol . rest)
'(("file") ("line")))
- (define (geiser-symbol-documentation toplevel-module symbol . rest)
- (let* ((sig (find-signatures toplevel-module symbol)))
+ (define (geiser-symbol-documentation symbol . rest)
+ (let* ((sig (find-signatures symbol)))
`(("signature" ,@(car sig))
("docstring" . ,(make-doc symbol)))))
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File and Buffer Operations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define geiser-load-paths (make-parameter '()))
- (define (geiser-find-file toplevel-module file . rest)
+ (define (geiser-find-file file . rest)
(let ((paths (append '("" ".") (geiser-load-paths))))
(define (try-find file paths)
(cond
@@ -636,7 +603,7 @@
(else (try-find file (cdr paths)))))
(try-find file paths)))
- (define (geiser-add-to-load-path toplevel-module directory . rest)
+ (define (geiser-add-to-load-path directory . rest)
(let* ((directory (if (symbol? directory)
(symbol->string directory)
directory))
@@ -648,9 +615,9 @@
(when (directory-exists? directory)
(geiser-load-paths (cons directory (geiser-load-paths))))))))
- (define (geiser-compile-file toplevel-module file . rest)
+ (define (geiser-compile-file file . rest)
(let* ((file (if (symbol? file) (symbol->string file) file))
- (found-file (geiser-find-file toplevel-module file)))
+ (found-file (geiser-find-file file)))
(call-with-result #f
(lambda ()
(when found-file
@@ -658,16 +625,16 @@
;; TODO: Support compiling regions
- (define (geiser-compile toplevel-module form module . rest)
+ (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 toplevel-module module-name . rest)
+ (define (geiser-module-exports module-name . rest)
(let* ((nodes (match-nodes module-name)))
(if (null? nodes)
'()
@@ -697,26 +664,23 @@
;; Returns the path for the file in which an egg or module was defined
- (define (geiser-module-path toplevel-module module-name . rest)
+ (define (geiser-module-path module-name . rest)
#f)
;; Returns:
;; `(("file" . ,(module-path name)) ("line"))
- (define (geiser-module-location toplevel-module name . rest)
+ (define (geiser-module-location name . rest)
#f)
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Misc
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define (geiser-macroexpand toplevel-module form . rest)
+ (define (geiser-macroexpand form . rest)
(with-output-to-string
(lambda ()
- (pretty-print (expand form)))))
+ (write (expand form)))))
;; End module
)
-
-(import geiser)
-(make-geiser-toplevel-bindings)