688 lines
26 KiB
Scheme
688 lines
26 KiB
Scheme
;; -*- 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 <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
|
||
|
||
(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<=? char-ci=? 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<=? string-ci=? 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-ci>=? char-ci>? char-downcase
|
||
char-lower-case? char-numeric? char-ready? char-upcase
|
||
char-upper-case? char-whitespace? char<=? char<? 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-ci>=? string-ci>?
|
||
string-copy string-fill! string-length string-ref string-set!
|
||
string<=? string<? 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>=? 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>=? 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-ci>=? char-ci>?
|
||
char-downcase char-lower-case? char-numeric? char-upcase
|
||
char-upper-case? char-whitespace? char<=? char<? 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-ci>=? string-ci>? string-copy string-fill! string-length
|
||
string-ref string-set! string<=? string<? 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 "<syntax>")
|
||
(display (string-append type " ")) (write line) (newline))
|
||
((equal? type "<eval>")
|
||
(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" <macro>)
|
||
("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
|
||
)
|