diff options
Diffstat (limited to 'scheme')
| -rw-r--r-- | scheme/chicken/geiser/emacs.scm | 456 |
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) |