From 149cf613ee81f40f678b08f1c451ad256d843c94 Mon Sep 17 00:00:00 2001 From: Dan Leslie Date: Sun, 11 Nov 2018 10:29:54 -0800 Subject: Removed more unused code, speeding things up. --- scheme/chicken/geiser/chicken4.scm | 687 +++++++++++++++++++++++++++++++++++++ scheme/chicken/geiser/chicken5.scm | 41 +-- scheme/chicken/geiser/emacs.scm | 687 ------------------------------------- 3 files changed, 692 insertions(+), 723 deletions(-) create mode 100644 scheme/chicken/geiser/chicken4.scm delete mode 100644 scheme/chicken/geiser/emacs.scm (limited to 'scheme/chicken/geiser') diff --git a/scheme/chicken/geiser/chicken4.scm b/scheme/chicken/geiser/chicken4.scm new file mode 100644 index 0000000..908f768 --- /dev/null +++ b/scheme/chicken/geiser/chicken4.scm @@ -0,0 +1,687 @@ +;; -*- geiser-scheme-implementation: 'chicken + +;; Copyright (C) 2015 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 . + +(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 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 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define geiser-r4rs-symbols + (make-parameter + '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar + caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar + cddadr cdddar cddddr set-car! set-cdr! null? list? list length + list-tail list-ref append reverse memq memv member assq assv assoc + symbol? symbol->string string->symbol number? integer? exact? real? + complex? inexact? rational? zero? odd? even? positive? negative? + max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs + floor ceiling truncate round exact->inexact inexact->exact exp log + expt sqrt sin cos tan asin acos atan number->string string->number + char? char=? char>? char=? char<=? char-ci=? char-ci? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? + char-numeric? char-upper-case? char-lower-case? char-upcase + char-downcase char->integer integer->char string? string=? string>? + string=? string<=? string-ci=? string-ci? + string-ci>=? string-ci<=? make-string string-length string-ref + string-set! string-append string-copy string->list list->string + substring string-fill! vector? make-vector vector-ref vector-set! + string vector vector-length vector->list list->vector vector-fill! + procedure? map for-each apply force call-with-current-continuation + input-port? output-port? current-input-port current-output-port + call-with-input-file call-with-output-file open-input-file + open-output-file close-input-port close-output-port load + read eof-object? read-char peek-char write display write-char + newline with-input-from-file with-output-to-file eval char-ready? + imag-part real-part magnitude numerator denominator + scheme-report-environment null-environment interaction-environment + else))) + + (define geiser-r5rs-symbols + (make-parameter + '(abs acos and angle append apply asin assoc assq assv atan begin + boolean? caar cadr call-with-current-continuation + call-with-input-file call-with-output-file call-with-values + car case cdddar cddddr cdr ceiling char->integer char-alphabetic? + char-ci<=? char-ci=? char-ci>? char-downcase + char-lower-case? char-numeric? char-ready? char-upcase + char-upper-case? char-whitespace? char<=? char=? + char>? char? close-input-port close-output-port complex? cond cons + cos current-input-port current-output-port define define-syntax + delay denominator display do dynamic-wind else eof-object? eq? + equal? eqv? eval even? exact->inexact exact? exp expt floor + for-each force gcd if imag-part inexact->exact inexact? input-port? + integer->char integer? interaction-environment lambda lcm length + let let* let-syntax letrec letrec-syntax list list->string + list->vector list-ref list-tail list? load log magnitude make-polar + make-rectangular make-string make-vector map max member memq memv + min modulo negative? newline not null-environment null? + number->string number? numerator odd? open-input-file + open-output-file or output-port? pair? peek-char port? positive? + procedure? quasiquote quote quotient rational? rationalize read + read-char real-part real? remainder reverse round + scheme-report-environment set! set-car! set-cdr! setcar sin sqrt + string string->list string->number string->symbol string-append + string-ci<=? string-ci=? string-ci>? + string-copy string-fill! string-length string-ref string-set! + string<=? string=? string>? string? substring + symbol->string symbol? syntax-rules tan transcript-off transcript-on + truncate values vector vector->list vector-fill! vector-length + vector-ref vector-set! vector? with-input-from-file with-output-to-file + write write-char zero?))) + + (define geiser-r7rs-small-symbols + (make-parameter + '(* + - ... / < <= = => > >= abs and append apply assoc assq + assv begin binary-port? boolean=? boolean? bytevector + bytevector-append bytevector-copy bytevector-copy! bytevector-length + bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr + call-with-current-continuation call-with-port call-with-values call/cc + car case cdar cddr cdr ceiling char->integer char-ready? char<=? + char=? char>? char? close-input-port + close-output-port close-port complex? cond cond-expand cons + current-error-port current-input-port current-output-port + define define-record-type define-syntax define-values denominator do + dynamic-wind else eof-object? equal? error error-object-message + even? exact-integer-sqrt exact? features floor floor-remainder + flush-output-port gcd get-output-string if include-ci inexact? + input-port? integer? lcm let let*-values let-values letrec* list + list->vector list-ref list-tail make-bytevector make-parameter + make-vector max memq min negative? not number->string numerator + open-input-bytevector open-output-bytevector or output-port? + parameterize peek-u8 positive? quasiquote quotient raise-continuable + rationalize read-bytevector! read-error? read-string real? reverse + set! set-cdr! string string->number string->utf8 string-append + eof-object eq? eqv? error-object-irritants error-object? exact + exact-integer? expt file-error? floor-quotient floor/ for-each + get-output-bytevector guard include inexact input-port-open? + integer->char lambda length let* let-syntax letrec letrec-syntax + list->string list-copy list-set! list? make-list make-string map + member memv modulo newline null? number? odd? open-input-string + open-output-string output-port-open? pair? peek-char port? + procedure? quote raise rational? read-bytevector read-char read-line + read-u8 remainder round set-car! square string->list string->symbol + string->vector string-copy string-copy! string-for-each string-map + string-set! string=? string? symbol->string symbol? + syntax-rules truncate truncate-remainder u8-ready? unquote + utf8->string vector vector->string vector-copy vector-fill! + vector-length vector-ref vector? with-exception-handler write-char + write-u8 string-fill! string-length string-ref string<=? + string=? string>? substring symbol=? syntax-error textual-port? + truncate-quotient truncate/ unless unquote-splicing values + vector->list vector-append vector-copy! vector-for-each vector-map + vector-set! when write-bytevector write-string zero?))) + + (define geiser-chicken-builtin-symbols + (make-parameter + '(and-let* assume compiler-typecase cond-expand condition-case cut cute declare define-constant + define-inline define-interface define-record define-record-type define-specialization + define-syntax-rule define-type define-values dotimes ecase fluid-let foreign-lambda + foreign-lambda* foreign-primitive foreign-safe-lambda foreign-safe-lambda* functor + handle-exceptions import let*-values let-location let-optionals let-optionals* + let-values letrec* letrec-values match-letrec module parameterize regex-case + require-extension select set! unless use when with-input-from-pipe match + match-lambda match-lambda* match-let match-let* receive))) + + (define geiser-chicken-crunch-symbols + (make-parameter + '(* + - / < <= = > >= abs acos add1 argc argv-ref arithmetic-shift asin + atan atan2 bitwise-and bitwise-ior bitwise-not bitwise-xor + blob->f32vector blob->f32vector/shared blob->f64vector + blob->f64vector/shared blob->s16vector blob->s16vector/shared + blob->s32vector blob->s32vector/shared blob->s8vector + blob->s8vector/shared blob->string blob->string/shared blob->u16vector + blob->u16vector/shared blob->u32vector blob->u32vector/shared + blob->u8vector blob->u8vector/shared ceiling char->integer + char-alphabetic? char-ci<=? char-ci=? char-ci>? + char-downcase char-lower-case? char-numeric? char-upcase + char-upper-case? char-whitespace? char<=? char=? char>? + cond-expand cos display display eq? equal? eqv? error even? + exact->inexact exact? exit exp expt f32vector->blob + f32vector->blob/shared f32vector-length f32vector-ref f32vector-set! + f64vector->blob f64vector->blob/shared f64vector-length f64vector-ref + f64vector-set! floor flush-output inexact->exact inexact? + integer->char integer? log make-f32vector make-f64vector make-s16vector + make-s32vector make-s8vector make-string make-u16vector make-u32vector + make-u8vector max min modulo negative? newline not number->string odd? + pointer-f32-ref pointer-f32-set! pointer-f64-ref pointer-f64-set! + pointer-s16-ref pointer-s16-set! pointer-s32-ref pointer-s32-set! + pointer-s8-ref pointer-s8-set! pointer-u16-ref pointer-u16-set! + pointer-u32-ref pointer-u32-set! pointer-u8-ref pointer-u8-set! + positive? quotient rec remainder round s16vector->blob + s16vector->blob/shared s16vector-length s16vector-ref s16vector-set! + s32vector->blob s32vector->blob/shared s32vector-length s32vector-ref + s32vector-set! s8vector->blob s8vector->blob/shared s8vector-length + s8vector-ref s8vector-set! sin sqrt string->blob string->blob/shared + string->number string-append string-ci<=? string-ci=? string-ci>? string-copy string-fill! string-length + string-ref string-set! string<=? string=? string>? + sub1 subf32vector subf64vector subs16vector subs32vector subs8vector + substring subu16vector subu32vector subu8vector switch tan truncate + u16vector->blob u16vector->blob/shared u16vector-length u16vector-ref + u16vector-set! u32vector->blob u32vector->blob/shared u32vector-length + u32vector-ref u32vector-set! u8vector->blob u8vector->blob/shared + u8vector-length u8vector-ref u8vector-set! unless void when write-char + zero?))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Utilities + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define geiser-chicken-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 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/shared s 1) (substring/shared 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 "") + (display (string-append type " ")) (write line) (newline)) + ((equal? type "") + (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)) + (module (maybe-call (lambda (v) (find-module module)) module)) + (original-module (current-module))) + + (set! output + (handle-exceptions exn + (with-all-output-to-string + (lambda () (write-exception exn))) + (with-all-output-to-string + (lambda () + (switch-module module) + (call-with-values thunk (lambda v (set! result v))))))) + + (switch-module original-module) + + (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 (find-standards-with-symbol sym) + (append + (if (any (cut eq? <> sym) (geiser-r4rs-symbols)) + '(r4rs) + '()) + (if (any (cut eq? <> sym) (geiser-r5rs-symbols)) + '(r5rs) + '()) + (if (any (cut eq? <> sym) (geiser-r7rs-small-symbols)) + '(r7rs) + '()) + (if (any (cut eq? <> sym) (geiser-chicken-builtin-symbols)) + '(chicken) + '()) + (if (any (cut eq? <> sym) (geiser-chicken-crunch-symbols)) + '(crunch) + '()))) + + ;; Locates any paths at which a particular symbol might be located + (define (find-library-paths sym types) + ;; Removes the given sym from the node path + (define (remove-self sym path) + (cond + ((not (list? path)) path) + ((null? path) path) + ((null? (cdr path)) + (if (eq? (car path) sym) + '() + path)) + (else + (cons (car path) (remove-self sym (cdr path)))))) + + (append + (map + (cut list <>) + (find-standards-with-symbol sym)) + (map + (lambda (node) + (remove-self sym (node-path node))) + (filter + (lambda (n) + (let ((type (node-type n))) + (any (cut eq? type <>) types))) + (match-nodes sym))))) + + (define (make-module-list sym module-sym) + (append + (if (not module-sym) + (find-standards-with-symbol sym) + (cons module-sym (find-standards-with-symbol sym))))) + + (define (read* str) + (with-input-from-string str (lambda () (read)))) + + (define (eval* str) + (cond + ((symbol? str) (eval str)) + ((string? str) (eval (read* str))) + (else (eval* (->string str))))) + + (define (fmt node) + (let* ((mod (cadr node)) + (sym (car node)) + (rest (cddr node)) + (type (if (or (list? rest) (pair? rest)) (car rest) rest)) + (mod-list (make-module-list sym mod))) + (cond + ((equal? 'macro type) + `(,sym ("args" (("required" ) + ("optional" ...) + ("key"))) + ("module" ,@mod-list))) + ((or (equal? 'variable type) + (equal? 'constant type)) + (if (not mod) + `(,sym ("value" . ,(eval* sym))) + (let* ((original-module (current-module)) + (desired-module (find-module mod)) + (value (begin (switch-module desired-module) + (eval* sym)))) + (switch-module original-module) + `(,sym ("value" . ,value) + ("module" ,@mod-list))))) + (else + (let ((reqs '()) + (opts '()) + (keys '()) + (args (if (or (list? rest) (pair? rest)) (cdr rest) '()))) + + (define (clean-arg arg) + (let ((s (->string arg))) + (read* (substring/shared s 0 (add1 (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) + + `(,sym ("args" (("required" ,@reqs) + ("optional" ,@opts) + ("key" ,@keys))) + ("module" ,@mod-list))))))) + + ;; Builds a signature list from an identifier + (define (find-signatures sym) + (let ((result (symbol-information-list sym))) + (map fmt result))) + + ;; Builds the documentation from Chicken Doc for a specific symbol + (define (make-doc symbol #!optional (filter-for-type #f)) + (with-output-to-string + (lambda () + (map (lambda (node) + (display (string-append "= Node: " (->string (node-id node)) " " " =\n")) + (describe node) + (display "\n\n")) + (filter + (lambda (n) + (or (not filter-for-type) + (eq? (node-type n) filter-for-type))) + (match-nodes symbol)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 (module-matches-defined-module? module) + (any (cut eq? module <>) (list-modules))) + + (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-matches-defined-module? module) + 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) + (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 symbol . rest) + '(("file") ("line"))) + + (define (geiser-symbol-documentation symbol . rest) + (let* ((sig (find-signatures symbol))) + `(("signature" ,@(car sig)) + ("docstring" . ,(make-doc symbol))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) + (let* ((file (if (symbol? file) (symbol->string file) file)) + (found-file (geiser-find-file file))) + (call-with-result #f + (lambda () + (when found-file + (compile-file found-file)))))) + + ;; 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) + (let* ((nodes (match-nodes module-name))) + (if (null? nodes) + '() + (let ((mod '()) + (proc '()) + (syn '()) + (var '())) + (map + (lambda (node) + (let ((type (node-type node)) + (name (node-id node)) + (path (node-path node))) + (cond + ((memq type '(unit egg)) + (set! mod (cons name mod))) + ((memq type '(procedure record setter class method)) + (set! proc (cons name proc))) + ((memq type '(read syntax)) + (set! syn (cons name syn))) + ((memq type '(parameter constant)) + (set! var (cons name var)))))) + nodes) + `(("modules" . ,mod) + ("procs" . ,proc) + ("syntax" . ,syn) + ("vars" . ,var)))))) + + ;; 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 + ) diff --git a/scheme/chicken/geiser/chicken5.scm b/scheme/chicken/geiser/chicken5.scm index f5f0c30..4ef110e 100644 --- a/scheme/chicken/geiser/chicken5.scm +++ b/scheme/chicken/geiser/chicken5.scm @@ -111,7 +111,7 @@ (if val (func val) #f)) ;; Wraps output from geiser functions - (define (call-with-result module thunk) + (define (call-with-result thunk) (let* ((result (if #f #f)) (output (if #f #f))) @@ -209,52 +209,21 @@ ;; 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]]) + (let* ((thunk (lambda () (eval form)))) (write-to-log form) - - (if is-safe-geiser? - (call-with-result #f thunk) - (call-with-result host-module thunk)))) + (call-with-result 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 + (call-with-result (lambda () (when found-file (load found-file)))))) @@ -355,7 +324,7 @@ (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory))))) (string-append directory "/") directory))) - (call-with-result #f + (call-with-result (lambda () (when (directory-exists? directory) (geiser-chicken-load-paths (cons directory (geiser-chicken-load-paths)))))))) diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm deleted file mode 100644 index 908f768..0000000 --- a/scheme/chicken/geiser/emacs.scm +++ /dev/null @@ -1,687 +0,0 @@ -;; -*- geiser-scheme-implementation: 'chicken - -;; Copyright (C) 2015 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 . - -(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 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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define geiser-r4rs-symbols - (make-parameter - '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar - caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar - cddadr cdddar cddddr set-car! set-cdr! null? list? list length - list-tail list-ref append reverse memq memv member assq assv assoc - symbol? symbol->string string->symbol number? integer? exact? real? - complex? inexact? rational? zero? odd? even? positive? negative? - max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs - floor ceiling truncate round exact->inexact inexact->exact exp log - expt sqrt sin cos tan asin acos atan number->string string->number - char? char=? char>? char=? char<=? char-ci=? char-ci? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? - char-numeric? char-upper-case? char-lower-case? char-upcase - char-downcase char->integer integer->char string? string=? string>? - string=? string<=? string-ci=? string-ci? - string-ci>=? string-ci<=? make-string string-length string-ref - string-set! string-append string-copy string->list list->string - substring string-fill! vector? make-vector vector-ref vector-set! - string vector vector-length vector->list list->vector vector-fill! - procedure? map for-each apply force call-with-current-continuation - input-port? output-port? current-input-port current-output-port - call-with-input-file call-with-output-file open-input-file - open-output-file close-input-port close-output-port load - read eof-object? read-char peek-char write display write-char - newline with-input-from-file with-output-to-file eval char-ready? - imag-part real-part magnitude numerator denominator - scheme-report-environment null-environment interaction-environment - else))) - - (define geiser-r5rs-symbols - (make-parameter - '(abs acos and angle append apply asin assoc assq assv atan begin - boolean? caar cadr call-with-current-continuation - call-with-input-file call-with-output-file call-with-values - car case cdddar cddddr cdr ceiling char->integer char-alphabetic? - char-ci<=? char-ci=? char-ci>? char-downcase - char-lower-case? char-numeric? char-ready? char-upcase - char-upper-case? char-whitespace? char<=? char=? - char>? char? close-input-port close-output-port complex? cond cons - cos current-input-port current-output-port define define-syntax - delay denominator display do dynamic-wind else eof-object? eq? - equal? eqv? eval even? exact->inexact exact? exp expt floor - for-each force gcd if imag-part inexact->exact inexact? input-port? - integer->char integer? interaction-environment lambda lcm length - let let* let-syntax letrec letrec-syntax list list->string - list->vector list-ref list-tail list? load log magnitude make-polar - make-rectangular make-string make-vector map max member memq memv - min modulo negative? newline not null-environment null? - number->string number? numerator odd? open-input-file - open-output-file or output-port? pair? peek-char port? positive? - procedure? quasiquote quote quotient rational? rationalize read - read-char real-part real? remainder reverse round - scheme-report-environment set! set-car! set-cdr! setcar sin sqrt - string string->list string->number string->symbol string-append - string-ci<=? string-ci=? string-ci>? - string-copy string-fill! string-length string-ref string-set! - string<=? string=? string>? string? substring - symbol->string symbol? syntax-rules tan transcript-off transcript-on - truncate values vector vector->list vector-fill! vector-length - vector-ref vector-set! vector? with-input-from-file with-output-to-file - write write-char zero?))) - - (define geiser-r7rs-small-symbols - (make-parameter - '(* + - ... / < <= = => > >= abs and append apply assoc assq - assv begin binary-port? boolean=? boolean? bytevector - bytevector-append bytevector-copy bytevector-copy! bytevector-length - bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr - call-with-current-continuation call-with-port call-with-values call/cc - car case cdar cddr cdr ceiling char->integer char-ready? char<=? - char=? char>? char? close-input-port - close-output-port close-port complex? cond cond-expand cons - current-error-port current-input-port current-output-port - define define-record-type define-syntax define-values denominator do - dynamic-wind else eof-object? equal? error error-object-message - even? exact-integer-sqrt exact? features floor floor-remainder - flush-output-port gcd get-output-string if include-ci inexact? - input-port? integer? lcm let let*-values let-values letrec* list - list->vector list-ref list-tail make-bytevector make-parameter - make-vector max memq min negative? not number->string numerator - open-input-bytevector open-output-bytevector or output-port? - parameterize peek-u8 positive? quasiquote quotient raise-continuable - rationalize read-bytevector! read-error? read-string real? reverse - set! set-cdr! string string->number string->utf8 string-append - eof-object eq? eqv? error-object-irritants error-object? exact - exact-integer? expt file-error? floor-quotient floor/ for-each - get-output-bytevector guard include inexact input-port-open? - integer->char lambda length let* let-syntax letrec letrec-syntax - list->string list-copy list-set! list? make-list make-string map - member memv modulo newline null? number? odd? open-input-string - open-output-string output-port-open? pair? peek-char port? - procedure? quote raise rational? read-bytevector read-char read-line - read-u8 remainder round set-car! square string->list string->symbol - string->vector string-copy string-copy! string-for-each string-map - string-set! string=? string? symbol->string symbol? - syntax-rules truncate truncate-remainder u8-ready? unquote - utf8->string vector vector->string vector-copy vector-fill! - vector-length vector-ref vector? with-exception-handler write-char - write-u8 string-fill! string-length string-ref string<=? - string=? string>? substring symbol=? syntax-error textual-port? - truncate-quotient truncate/ unless unquote-splicing values - vector->list vector-append vector-copy! vector-for-each vector-map - vector-set! when write-bytevector write-string zero?))) - - (define geiser-chicken-builtin-symbols - (make-parameter - '(and-let* assume compiler-typecase cond-expand condition-case cut cute declare define-constant - define-inline define-interface define-record define-record-type define-specialization - define-syntax-rule define-type define-values dotimes ecase fluid-let foreign-lambda - foreign-lambda* foreign-primitive foreign-safe-lambda foreign-safe-lambda* functor - handle-exceptions import let*-values let-location let-optionals let-optionals* - let-values letrec* letrec-values match-letrec module parameterize regex-case - require-extension select set! unless use when with-input-from-pipe match - match-lambda match-lambda* match-let match-let* receive))) - - (define geiser-chicken-crunch-symbols - (make-parameter - '(* + - / < <= = > >= abs acos add1 argc argv-ref arithmetic-shift asin - atan atan2 bitwise-and bitwise-ior bitwise-not bitwise-xor - blob->f32vector blob->f32vector/shared blob->f64vector - blob->f64vector/shared blob->s16vector blob->s16vector/shared - blob->s32vector blob->s32vector/shared blob->s8vector - blob->s8vector/shared blob->string blob->string/shared blob->u16vector - blob->u16vector/shared blob->u32vector blob->u32vector/shared - blob->u8vector blob->u8vector/shared ceiling char->integer - char-alphabetic? char-ci<=? char-ci=? char-ci>? - char-downcase char-lower-case? char-numeric? char-upcase - char-upper-case? char-whitespace? char<=? char=? char>? - cond-expand cos display display eq? equal? eqv? error even? - exact->inexact exact? exit exp expt f32vector->blob - f32vector->blob/shared f32vector-length f32vector-ref f32vector-set! - f64vector->blob f64vector->blob/shared f64vector-length f64vector-ref - f64vector-set! floor flush-output inexact->exact inexact? - integer->char integer? log make-f32vector make-f64vector make-s16vector - make-s32vector make-s8vector make-string make-u16vector make-u32vector - make-u8vector max min modulo negative? newline not number->string odd? - pointer-f32-ref pointer-f32-set! pointer-f64-ref pointer-f64-set! - pointer-s16-ref pointer-s16-set! pointer-s32-ref pointer-s32-set! - pointer-s8-ref pointer-s8-set! pointer-u16-ref pointer-u16-set! - pointer-u32-ref pointer-u32-set! pointer-u8-ref pointer-u8-set! - positive? quotient rec remainder round s16vector->blob - s16vector->blob/shared s16vector-length s16vector-ref s16vector-set! - s32vector->blob s32vector->blob/shared s32vector-length s32vector-ref - s32vector-set! s8vector->blob s8vector->blob/shared s8vector-length - s8vector-ref s8vector-set! sin sqrt string->blob string->blob/shared - string->number string-append string-ci<=? string-ci=? string-ci>? string-copy string-fill! string-length - string-ref string-set! string<=? string=? string>? - sub1 subf32vector subf64vector subs16vector subs32vector subs8vector - substring subu16vector subu32vector subu8vector switch tan truncate - u16vector->blob u16vector->blob/shared u16vector-length u16vector-ref - u16vector-set! u32vector->blob u32vector->blob/shared u32vector-length - u32vector-ref u32vector-set! u8vector->blob u8vector->blob/shared - u8vector-length u8vector-ref u8vector-set! unless void when write-char - zero?))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Utilities - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define geiser-chicken-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 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/shared s 1) (substring/shared 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 "") - (display (string-append type " ")) (write line) (newline)) - ((equal? type "") - (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)) - (module (maybe-call (lambda (v) (find-module module)) module)) - (original-module (current-module))) - - (set! output - (handle-exceptions exn - (with-all-output-to-string - (lambda () (write-exception exn))) - (with-all-output-to-string - (lambda () - (switch-module module) - (call-with-values thunk (lambda v (set! result v))))))) - - (switch-module original-module) - - (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 (find-standards-with-symbol sym) - (append - (if (any (cut eq? <> sym) (geiser-r4rs-symbols)) - '(r4rs) - '()) - (if (any (cut eq? <> sym) (geiser-r5rs-symbols)) - '(r5rs) - '()) - (if (any (cut eq? <> sym) (geiser-r7rs-small-symbols)) - '(r7rs) - '()) - (if (any (cut eq? <> sym) (geiser-chicken-builtin-symbols)) - '(chicken) - '()) - (if (any (cut eq? <> sym) (geiser-chicken-crunch-symbols)) - '(crunch) - '()))) - - ;; Locates any paths at which a particular symbol might be located - (define (find-library-paths sym types) - ;; Removes the given sym from the node path - (define (remove-self sym path) - (cond - ((not (list? path)) path) - ((null? path) path) - ((null? (cdr path)) - (if (eq? (car path) sym) - '() - path)) - (else - (cons (car path) (remove-self sym (cdr path)))))) - - (append - (map - (cut list <>) - (find-standards-with-symbol sym)) - (map - (lambda (node) - (remove-self sym (node-path node))) - (filter - (lambda (n) - (let ((type (node-type n))) - (any (cut eq? type <>) types))) - (match-nodes sym))))) - - (define (make-module-list sym module-sym) - (append - (if (not module-sym) - (find-standards-with-symbol sym) - (cons module-sym (find-standards-with-symbol sym))))) - - (define (read* str) - (with-input-from-string str (lambda () (read)))) - - (define (eval* str) - (cond - ((symbol? str) (eval str)) - ((string? str) (eval (read* str))) - (else (eval* (->string str))))) - - (define (fmt node) - (let* ((mod (cadr node)) - (sym (car node)) - (rest (cddr node)) - (type (if (or (list? rest) (pair? rest)) (car rest) rest)) - (mod-list (make-module-list sym mod))) - (cond - ((equal? 'macro type) - `(,sym ("args" (("required" ) - ("optional" ...) - ("key"))) - ("module" ,@mod-list))) - ((or (equal? 'variable type) - (equal? 'constant type)) - (if (not mod) - `(,sym ("value" . ,(eval* sym))) - (let* ((original-module (current-module)) - (desired-module (find-module mod)) - (value (begin (switch-module desired-module) - (eval* sym)))) - (switch-module original-module) - `(,sym ("value" . ,value) - ("module" ,@mod-list))))) - (else - (let ((reqs '()) - (opts '()) - (keys '()) - (args (if (or (list? rest) (pair? rest)) (cdr rest) '()))) - - (define (clean-arg arg) - (let ((s (->string arg))) - (read* (substring/shared s 0 (add1 (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) - - `(,sym ("args" (("required" ,@reqs) - ("optional" ,@opts) - ("key" ,@keys))) - ("module" ,@mod-list))))))) - - ;; Builds a signature list from an identifier - (define (find-signatures sym) - (let ((result (symbol-information-list sym))) - (map fmt result))) - - ;; Builds the documentation from Chicken Doc for a specific symbol - (define (make-doc symbol #!optional (filter-for-type #f)) - (with-output-to-string - (lambda () - (map (lambda (node) - (display (string-append "= Node: " (->string (node-id node)) " " " =\n")) - (describe node) - (display "\n\n")) - (filter - (lambda (n) - (or (not filter-for-type) - (eq? (node-type n) filter-for-type))) - (match-nodes symbol)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; 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 (module-matches-defined-module? module) - (any (cut eq? module <>) (list-modules))) - - (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-matches-defined-module? module) - 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) - (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 symbol . rest) - '(("file") ("line"))) - - (define (geiser-symbol-documentation symbol . rest) - (let* ((sig (find-signatures symbol))) - `(("signature" ,@(car sig)) - ("docstring" . ,(make-doc symbol))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; 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) - (let* ((file (if (symbol? file) (symbol->string file) file)) - (found-file (geiser-find-file file))) - (call-with-result #f - (lambda () - (when found-file - (compile-file found-file)))))) - - ;; 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) - (let* ((nodes (match-nodes module-name))) - (if (null? nodes) - '() - (let ((mod '()) - (proc '()) - (syn '()) - (var '())) - (map - (lambda (node) - (let ((type (node-type node)) - (name (node-id node)) - (path (node-path node))) - (cond - ((memq type '(unit egg)) - (set! mod (cons name mod))) - ((memq type '(procedure record setter class method)) - (set! proc (cons name proc))) - ((memq type '(read syntax)) - (set! syn (cons name syn))) - ((memq type '(parameter constant)) - (set! var (cons name var)))))) - nodes) - `(("modules" . ,mod) - ("procs" . ,proc) - ("syntax" . ,syn) - ("vars" . ,var)))))) - - ;; 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 - ) -- cgit v1.2.3