| blob | 6b7124f3ed0c60b64912f16cafb7e780d7f81016 |
1 ;; -*- geiser-scheme-implementation: 'chicken
3 ;; Copyright (C) 2015 Daniel J Leslie
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the Modified BSD License. You should
7 ;; have received a copy of the license along with this program. If
8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
10 (module geiser
11 (geiser-eval
12 geiser-no-values
13 geiser-newline
14 geiser-start-server
15 geiser-completions
16 geiser-autodoc
17 geiser-object-signature
18 geiser-symbol-location
19 geiser-symbol-documentation
20 geiser-find-file
21 geiser-add-to-load-path
22 geiser-load-file
23 geiser-compile-file
24 geiser-compile
25 geiser-module-exports
26 geiser-module-path
27 geiser-module-location
28 geiser-module-completions
29 geiser-macroexpand
30 geiser-use-debug-log
31 geiser-load-paths)
33 (import chicken scheme)
34 (use
35 apropos
36 chicken-doc
37 data-structures
38 extras
39 ports
40 posix
41 srfi-1
42 srfi-13
43 srfi-14
44 srfi-18
45 srfi-69
46 tcp
47 utils)
49 \f
50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 ;; Symbol lists
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 (define geiser-r4rs-symbols
55 (make-parameter
56 '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr
57 caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar
58 caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar
59 cddadr cdddar cddddr set-car! set-cdr! null? list? list length
60 list-tail list-ref append reverse memq memv member assq assv assoc
61 symbol? symbol->string string->symbol number? integer? exact? real?
62 complex? inexact? rational? zero? odd? even? positive? negative?
63 max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs
64 floor ceiling truncate round exact->inexact inexact->exact exp log
65 expt sqrt sin cos tan asin acos atan number->string string->number
66 char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<?
67 char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace?
68 char-numeric? char-upper-case? char-lower-case? char-upcase
69 char-downcase char->integer integer->char string? string=? string>?
70 string<? string>=? string<=? string-ci=? string-ci<? string-ci>?
71 string-ci>=? string-ci<=? make-string string-length string-ref
72 string-set! string-append string-copy string->list list->string
73 substring string-fill! vector? make-vector vector-ref vector-set!
74 string vector vector-length vector->list list->vector vector-fill!
75 procedure? map for-each apply force call-with-current-continuation
76 input-port? output-port? current-input-port current-output-port
77 call-with-input-file call-with-output-file open-input-file
78 open-output-file close-input-port close-output-port load
79 read eof-object? read-char peek-char write display write-char
80 newline with-input-from-file with-output-to-file eval char-ready?
81 imag-part real-part magnitude numerator denominator
82 scheme-report-environment null-environment interaction-environment
83 else)))
85 (define geiser-r5rs-symbols
86 (make-parameter
87 '(abs acos and angle append apply asin assoc assq assv atan begin
88 boolean? caar cadr call-with-current-continuation
89 call-with-input-file call-with-output-file call-with-values
90 car case cdddar cddddr cdr ceiling char->integer char-alphabetic?
91 char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase
92 char-lower-case? char-numeric? char-ready? char-upcase
93 char-upper-case? char-whitespace? char<=? char<? char=? char>=?
94 char>? char? close-input-port close-output-port complex? cond cons
95 cos current-input-port current-output-port define define-syntax
96 delay denominator display do dynamic-wind else eof-object? eq?
97 equal? eqv? eval even? exact->inexact exact? exp expt floor
98 for-each force gcd if imag-part inexact->exact inexact? input-port?
99 integer->char integer? interaction-environment lambda lcm length
100 let let* let-syntax letrec letrec-syntax list list->string
101 list->vector list-ref list-tail list? load log magnitude make-polar
102 make-rectangular make-string make-vector map max member memq memv
103 min modulo negative? newline not null-environment null?
104 number->string number? numerator odd? open-input-file
105 open-output-file or output-port? pair? peek-char port? positive?
106 procedure? quasiquote quote quotient rational? rationalize read
107 read-char real-part real? remainder reverse round
108 scheme-report-environment set! set-car! set-cdr! setcar sin sqrt
109 string string->list string->number string->symbol string-append
110 string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
111 string-copy string-fill! string-length string-ref string-set!
112 string<=? string<? string=? string>=? string>? string? substring
113 symbol->string symbol? syntax-rules tan transcript-off transcript-on
114 truncate values vector vector->list vector-fill! vector-length
115 vector-ref vector-set! vector? with-input-from-file with-output-to-file
116 write write-char zero?)))
118 (define geiser-r7rs-small-symbols
119 (make-parameter
120 '(* + - ... / < <= = => > >= abs and append apply assoc assq
121 assv begin binary-port? boolean=? boolean? bytevector
122 bytevector-append bytevector-copy bytevector-copy! bytevector-length
123 bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
124 call-with-current-continuation call-with-port call-with-values call/cc
125 car case cdar cddr cdr ceiling char->integer char-ready? char<=?
126 char<? char=? char>=? char>? char? close-input-port
127 close-output-port close-port complex? cond cond-expand cons
128 current-error-port current-input-port current-output-port
129 define define-record-type define-syntax define-values denominator do
130 dynamic-wind else eof-object? equal? error error-object-message
131 even? exact-integer-sqrt exact? features floor floor-remainder
132 flush-output-port gcd get-output-string if include-ci inexact?
133 input-port? integer? lcm let let*-values let-values letrec* list
134 list->vector list-ref list-tail make-bytevector make-parameter
135 make-vector max memq min negative? not number->string numerator
136 open-input-bytevector open-output-bytevector or output-port?
137 parameterize peek-u8 positive? quasiquote quotient raise-continuable
138 rationalize read-bytevector! read-error? read-string real? reverse
139 set! set-cdr! string string->number string->utf8 string-append
140 eof-object eq? eqv? error-object-irritants error-object? exact
141 exact-integer? expt file-error? floor-quotient floor/ for-each
142 get-output-bytevector guard include inexact input-port-open?
143 integer->char lambda length let* let-syntax letrec letrec-syntax
144 list->string list-copy list-set! list? make-list make-string map
145 member memv modulo newline null? number? odd? open-input-string
146 open-output-string output-port-open? pair? peek-char port?
147 procedure? quote raise rational? read-bytevector read-char read-line
148 read-u8 remainder round set-car! square string->list string->symbol
149 string->vector string-copy string-copy! string-for-each string-map
150 string-set! string<? string>=? string? symbol->string symbol?
151 syntax-rules truncate truncate-remainder u8-ready? unquote
152 utf8->string vector vector->string vector-copy vector-fill!
153 vector-length vector-ref vector? with-exception-handler write-char
154 write-u8 string-fill! string-length string-ref string<=?
155 string=? string>? substring symbol=? syntax-error textual-port?
156 truncate-quotient truncate/ unless unquote-splicing values
157 vector->list vector-append vector-copy! vector-for-each vector-map
158 vector-set! when write-bytevector write-string zero?)))
160 (define geiser-chicken-builtin-symbols
161 (make-parameter
162 '(and-let* assume compiler-typecase cond-expand condition-case cut cute declare define-constant
163 define-inline define-interface define-record define-record-type define-specialization
164 define-syntax-rule define-type define-values dotimes ecase fluid-let foreign-lambda
165 foreign-lambda* foreign-primitive foreign-safe-lambda foreign-safe-lambda* functor
166 handle-exceptions import let*-values let-location let-optionals let-optionals*
167 let-values letrec* letrec-values match-letrec module parameterize regex-case
168 require-extension select set! unless use when with-input-from-pipe match
169 match-lambda match-lambda* match-let match-let* receive)))
171 (define geiser-chicken-crunch-symbols
172 (make-parameter
173 '(* + - / < <= = > >= abs acos add1 argc argv-ref arithmetic-shift asin
174 atan atan2 bitwise-and bitwise-ior bitwise-not bitwise-xor
175 blob->f32vector blob->f32vector/shared blob->f64vector
176 blob->f64vector/shared blob->s16vector blob->s16vector/shared
177 blob->s32vector blob->s32vector/shared blob->s8vector
178 blob->s8vector/shared blob->string blob->string/shared blob->u16vector
179 blob->u16vector/shared blob->u32vector blob->u32vector/shared
180 blob->u8vector blob->u8vector/shared ceiling char->integer
181 char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
182 char-downcase char-lower-case? char-numeric? char-upcase
183 char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>?
184 cond-expand cos display display eq? equal? eqv? error even?
185 exact->inexact exact? exit exp expt f32vector->blob
186 f32vector->blob/shared f32vector-length f32vector-ref f32vector-set!
187 f64vector->blob f64vector->blob/shared f64vector-length f64vector-ref
188 f64vector-set! floor flush-output inexact->exact inexact?
189 integer->char integer? log make-f32vector make-f64vector make-s16vector
190 make-s32vector make-s8vector make-string make-u16vector make-u32vector
191 make-u8vector max min modulo negative? newline not number->string odd?
192 pointer-f32-ref pointer-f32-set! pointer-f64-ref pointer-f64-set!
193 pointer-s16-ref pointer-s16-set! pointer-s32-ref pointer-s32-set!
194 pointer-s8-ref pointer-s8-set! pointer-u16-ref pointer-u16-set!
195 pointer-u32-ref pointer-u32-set! pointer-u8-ref pointer-u8-set!
196 positive? quotient rec remainder round s16vector->blob
197 s16vector->blob/shared s16vector-length s16vector-ref s16vector-set!
198 s32vector->blob s32vector->blob/shared s32vector-length s32vector-ref
199 s32vector-set! s8vector->blob s8vector->blob/shared s8vector-length
200 s8vector-ref s8vector-set! sin sqrt string->blob string->blob/shared
201 string->number string-append string-ci<=? string-ci<? string-ci=?
202 string-ci>=? string-ci>? string-copy string-fill! string-length
203 string-ref string-set! string<=? string<? string=? string>=? string>?
204 sub1 subf32vector subf64vector subs16vector subs32vector subs8vector
205 substring subu16vector subu32vector subu8vector switch tan truncate
206 u16vector->blob u16vector->blob/shared u16vector-length u16vector-ref
207 u16vector-set! u32vector->blob u32vector->blob/shared u32vector-length
208 u32vector-ref u32vector-set! u8vector->blob u8vector->blob/shared
209 u8vector-length u8vector-ref u8vector-set! unless void when write-char
210 zero?)))
211 \f
212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
213 ;; Utilities
214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
216 (define geiser-use-debug-log (make-parameter #f))
218 (define find-module ##sys#find-module)
219 (define current-module ##sys#current-module)
220 (define switch-module ##sys#switch-module)
221 (define module-name ##sys#module-name)
222 (define (list-modules) (map car ##sys#module-table))
224 (define memo (make-parameter (make-hash-table)))
225 (define (clear-memo) (hash-table-clear! (memo)))
226 (define (memoize tag thunk)
227 (let ((table (memo)))
228 (if (hash-table-exists? table tag)
229 (begin
230 (write-to-log '[[Cache Hit]])
231 (hash-table-ref table tag))
232 (fluid-let ((memoize (lambda (tag thunk) (thunk))))
233 (write-to-log '[[Cache Miss]])
234 (hash-table-set! table tag (thunk))
236 (hash-table-ref table tag)))))
238 (define (symbol-information-list)
239 (memoize
240 '(symbol-information-list)
241 (lambda ()
242 (map (lambda (lst)
243 (let-values (((name module) (remove-internal-name-mangling (car lst))))
244 (append (list name module) (cdr lst))))
245 (apropos-information-list "" #:macros? #t)))))
247 (define (find-symbol-information prefix)
248 (define (find-symbol-information* prefix skipped)
249 (let ((found (filter
250 (lambda (info)
251 (string-has-prefix? (car info) prefix))
252 (symbol-information-list))))
253 ;; (if (and (null? found) (< 1 (string-length prefix)))
254 ;; (find-symbol-information* (substring/shared prefix 1) (string-append skipped (substring prefix 0 1))))
255 (cons found skipped)))
256 (memoize
257 `(find-symbol-information ,prefix)
258 (lambda ()
259 (find-symbol-information* (->string prefix) ""))))
261 (define debug-log (make-parameter #f))
262 (define (write-to-log form)
263 (when (geiser-use-debug-log)
264 (when (not (debug-log))
265 (debug-log (file-open "geiser.log" (+ open/wronly open/append open/text open/creat)))
266 (set-file-position! (debug-log) 0 seek/end))
267 (file-write (debug-log) (with-all-output-to-string (lambda () (write form) (newline))))
268 (file-write (debug-log) "\n")))
270 (define (remove-internal-name-mangling sym)
271 (let* ((sym (symbol->string sym))
272 (octothorpe-index (string-index-right sym #\#)))
273 (if octothorpe-index
274 (values (substring/shared sym (add1 octothorpe-index))
275 (substring/shared sym 0 octothorpe-index))
276 (values sym #f))))
278 (define (string-has-prefix? s prefix)
279 (cond
280 ((= 0 (string-length prefix)) #t)
281 ((= 0 (string-length s)) #f)
282 ((eq? (string-ref s 0) (string-ref prefix 0))
283 (string-has-prefix? (substring/shared s 1) (substring/shared prefix 1)))
284 (else #f)))
286 ;; This really should be a chicken library function
287 (define (write-exception exn)
288 (define (write-call-entry call)
289 (let ((type (vector-ref call 0))
290 (line (vector-ref call 1)))
291 (cond
292 ((equal? type "<syntax>")
293 (display (string-append type " ")) (write line) (newline))
294 ((equal? type "<eval>")
295 (display (string-append type " ")) (write line) (newline)))))
297 (display (format "Error: (~s) ~s: ~s"
298 ((condition-property-accessor 'exn 'location) exn)
299 ((condition-property-accessor 'exn 'message) exn)
300 ((condition-property-accessor 'exn 'arguments) exn)))
301 (newline)
302 (display "Call history: ") (newline)
303 (map write-call-entry ((condition-property-accessor 'exn 'call-chain) exn))
304 (newline))
306 ;; And this should be a chicken library function as well
307 (define (with-all-output-to-string thunk)
308 (with-output-to-string
309 (lambda ()
310 (with-error-output-to-port
311 (current-output-port)
312 thunk))))
314 (define (maybe-call func val)
315 (if val (func val) #f))
317 ;; Wraps output from geiser functions
318 (define (call-with-result module thunk)
319 (let* ((result (if #f #f))
320 (output (if #f #f))
321 (module (maybe-call (lambda (v) (find-module module)) module))
322 (original-module (current-module)))
324 (set! output
325 (handle-exceptions exn
326 (with-all-output-to-string
327 (lambda () (write-exception exn)))
328 (with-all-output-to-string
329 (lambda ()
330 (switch-module module)
331 (call-with-values thunk (lambda v (set! result v)))))))
333 (switch-module original-module)
335 (set! result
336 (cond
337 ((list? result)
338 (map (lambda (v) (with-output-to-string (lambda () (write v)))) result))
339 ((eq? result (if #f #t))
340 (list output))
341 (else
342 (list (with-output-to-string (lambda () (write result)))))))
344 (let ((out-form
345 `((result ,@result)
346 (output . ,output))))
347 (write out-form)
348 (write-to-log '[[RESPONSE]])
349 (write-to-log out-form))
351 (newline)))
353 (define (find-standards-with-symbol sym)
354 (append
355 (if (any (cut eq? <> sym) (geiser-r4rs-symbols))
356 '(r4rs)
357 '())
358 (if (any (cut eq? <> sym) (geiser-r5rs-symbols))
359 '(r5rs)
360 '())
361 (if (any (cut eq? <> sym) (geiser-r7rs-small-symbols))
362 '(r7rs)
363 '())
364 (if (any (cut eq? <> sym) (geiser-chicken-builtin-symbols))
365 '(chicken)
366 '())
367 (if (any (cut eq? <> sym) (geiser-chicken-crunch-symbols))
368 '(crunch)
369 '())))
371 ;; Locates any paths at which a particular symbol might be located
372 (define (find-library-paths sym types)
373 ;; Removes the given sym from the node path
374 (define (remove-self sym path)
375 (cond
376 ((not (list? path)) path)
377 ((null? path) path)
378 ((null? (cdr path))
379 (if (eq? (car path) sym)
380 '()
381 path))
382 (else
383 (cons (car path) (remove-self sym (cdr path))))))
385 (append
386 (map
387 (cut list <>)
388 (find-standards-with-symbol sym))
389 (map
390 (lambda (node)
391 (remove-self sym (node-path node)))
392 (filter
393 (lambda (n)
394 (let ((type (node-type n)))
395 (any (cut eq? type <>) types)))
396 (match-nodes sym)))))
398 (define (make-module-list sym module-sym prefix-exists)
399 (append
400 (if prefix-exists '(fuzzy-match) '())
401 (if (not module-sym)
402 (find-standards-with-symbol sym)
403 (cons module-sym (find-standards-with-symbol sym)))))
405 (define (fmt node prefix)
406 (memoize
407 `(fmt ,node ,prefix)
408 (lambda ()
409 (let* ((original-entry (string->symbol (car node)))
410 (fuzzy-entry (string->symbol (string-append prefix (car node))))
411 (prefix-exists (not (= 0 (string-length prefix))))
412 (module (cadr node))
413 (module (if module (string->symbol module) #f))
414 (rest (cddr node))
415 (type (if (or (list? rest) (pair? rest)) (car rest) rest))
416 (module-list (make-module-list fuzzy-entry module prefix-exists)))
417 (cond
418 ((equal? 'macro type)
419 `(,fuzzy-entry ("args" (("required" <macro>)
420 ("optional" ...)
421 ("key")))
422 ("module" ,@module-list)))
423 ((or (equal? 'variable type)
424 (equal? 'constant type))
425 (if (not module)
426 `(,fuzzy-entry ("value" . ,(eval original-entry)))
427 (let* ((original-module (current-module))
428 (desired-module (find-module module))
429 (value (begin (switch-module desired-module)
430 (eval original-entry))))
431 (switch-module original-module)
432 `(,fuzzy-entry ("value" . ,value)
433 ("module" ,@module-list)))))
434 (else
435 (let ((reqs '())
436 (opts '())
437 (keys '())
438 (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
440 (define (clean-arg arg)
441 (let ((s (->string arg)))
442 (string->symbol (substring/shared s 0 (add1 (string-skip-right s char-set:digit))))))
444 (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
445 (when (not (null? args))
446 (cond
447 ((or (pair? args) (list? args))
448 (cond
449 ((eq? '#!key (car args))
450 (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
451 ((eq? '#!optional (car args))
452 (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
453 (else
454 (begin
455 (cond
456 (reqs?
457 (set! reqs (append reqs (list (clean-arg (car args))))))
458 (opts?
459 (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
460 (keys?
461 (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
462 (collect-args (cdr args))))))
463 (else
464 (set! opts (list (clean-arg args) '...))))))
466 (collect-args args)
468 `(,fuzzy-entry ("args" (("required" ,@reqs)
469 ("optional" ,@opts)
470 ("key" ,@keys)))
471 ("module" ,@module-list)))))))))
473 ;; Builds a signature list from an identifier
474 (define (find-signatures sym)
475 (memoize
476 `(find-signatures ,sym)
477 (lambda ()
478 (let ((result (find-symbol-information sym)))
479 (map
480 (cut fmt <> (cdr result))
481 (car result))))))
483 ;; Builds the documentation from Chicken Doc for a specific symbol
484 (define (make-doc symbol #!optional (filter-for-type #f))
485 (with-output-to-string
486 (lambda ()
487 (map (lambda (node)
488 (display (string-append "= Node: " (->string (node-id node)) " " " =\n"))
489 (describe node)
490 (display "\n\n"))
491 (filter
492 (lambda (n)
493 (or (not filter-for-type)
494 (eq? (node-type n) filter-for-type)))
495 (match-nodes symbol))))))
497 \f
498 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
499 ;; Geiser core functions
500 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
502 ;; Basically all non-core functions pass through geiser-eval
504 (define (geiser-eval module form . rest)
505 (define (form-has-safe-geiser? form)
506 (any (cut eq? (car form) <>)
507 '(geiser-no-values geiser-newline geiser-completions
508 geiser-autodoc geiser-object-signature geiser-symbol-location
509 geiser-symbol-documentation geiser-module-exports
510 geiser-module-path geiser-module-location
511 geiser-module-completions geiser-use-debug-log)))
513 (define (form-has-any-geiser? form)
514 (string-has-prefix? (->string (car form)) "geiser-"))
516 (define (form-defines-any-module? form)
517 (or
518 ;; Geiser seems to send buffers as (begin ..buffer contents..)
519 (and (eq? (car form) 'begin)
520 (form-defines-any-module? (cadr form)))
521 (any (cut eq? (car form) <>)
522 '(module define-library))))
524 (define (module-matches-defined-module? module)
525 (any (cut eq? module <>) (list-modules)))
527 (when (and module (not (symbol? module)))
528 (error "Module should be a symbol"))
530 ;; All calls start at toplevel
531 (let* ((is-safe-geiser? (form-has-safe-geiser? form))
532 (host-module (and (not is-safe-geiser?)
533 (not (form-has-any-geiser? form))
534 (not (form-defines-any-module? form))
535 (module-matches-defined-module? module)
536 module))
537 (thunk (lambda () (eval form))))
539 (write-to-log `[[REQUEST host-module: ,host-module]])
540 (write-to-log form)
542 (if is-safe-geiser?
543 (call-with-result #f (lambda () (memoize form thunk)))
544 (begin
545 (clear-memo)
546 (call-with-result host-module thunk)))))
548 ;; Load a file
550 (define (geiser-load-file file)
551 (let* ((file (if (symbol? file) (symbol->string file) file))
552 (found-file (geiser-find-file file)))
553 (call-with-result #f
554 (lambda ()
555 (when found-file
556 (load found-file))))))
558 ;; The no-values identity
560 (define (geiser-no-values)
561 (values))
562 \f
563 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
564 ;; Miscellaneous
565 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
567 ;; Invoke a newline
569 (define (geiser-newline . rest)
570 (newline))
572 ;; Spawn a server for remote repl access
574 (define (geiser-start-server . rest)
575 (let* ((listener (tcp-listen 0))
576 (port (tcp-listener-port listener)))
577 (define (remote-repl)
578 (receive (in out) (tcp-accept listener)
579 (current-input-port in)
580 (current-output-port out)
581 (current-error-port out)
583 (repl)))
585 (thread-start! (make-thread remote-repl))
587 (write-to-log `(geiser-start-server . ,rest))
588 (write-to-log `(port ,port))
590 (write `(port ,port))
591 (newline)))
592 \f
593 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
594 ;; Completions, Autodoc and Signature
595 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
597 (define (geiser-completions prefix . rest)
598 (let* ((result (find-symbol-information prefix))
599 (prefix (cdr result))
600 (result-list (car result)))
601 (map
602 (cut string-append prefix <>)
603 (map car result-list))))
605 (define (geiser-module-completions prefix . rest)
606 (let ((prefix (->string prefix)))
607 (filter (cut string-has-prefix? <> prefix) (map ->string (list-modules)))))
609 (define (geiser-autodoc ids . rest)
610 (cond
611 ((null? ids) '())
612 ((not (list? ids))
613 (geiser-autodoc (list ids)))
614 ((not (symbol? (car ids)))
615 (geiser-autodoc (cdr ids)))
616 (else
617 (let ((details (find-signatures (car ids))))
618 (if (null? details)
619 (geiser-autodoc (cdr ids))
620 details)))))
622 (define (geiser-object-signature name object . rest)
623 (let* ((sig (geiser-autodoc `(,name))))
624 (if (null? sig) '() (car sig))))
626 ;; TODO: Divine some way to support this functionality
628 (define (geiser-symbol-location symbol . rest)
629 '(("file") ("line")))
631 (define (geiser-symbol-documentation symbol . rest)
632 (let* ((sig (find-signatures symbol)))
633 `(("signature" ,@(car sig))
634 ("docstring" . ,(make-doc symbol)))))
635 \f
636 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
637 ;; File and Buffer Operations
638 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
640 (define geiser-load-paths (make-parameter '("" ".")))
642 (define (geiser-find-file file . rest)
643 (when file
644 (let ((paths (geiser-load-paths)))
645 (define (try-find file paths)
646 (cond
647 ((null? paths) #f)
648 ((file-exists? (string-append (car paths) file))
649 (string-append (car paths) file))
650 (else (try-find file (cdr paths)))))
651 (try-find file paths))))
653 (define (geiser-add-to-load-path directory . rest)
654 (let* ((directory (if (symbol? directory)
655 (symbol->string directory)
656 directory))
657 (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory)))))
658 (string-append directory "/")
659 directory)))
660 (call-with-result #f
661 (lambda ()
662 (when (directory-exists? directory)
663 (geiser-load-paths (cons directory (geiser-load-paths))))))))
665 (define (geiser-compile-file file . rest)
666 (let* ((file (if (symbol? file) (symbol->string file) file))
667 (found-file (geiser-find-file file)))
668 (call-with-result #f
669 (lambda ()
670 (when found-file
671 (compile-file found-file))))))
673 ;; TODO: Support compiling regions
675 (define (geiser-compile form module . rest)
676 (error "Chicken does not support compiling regions"))
677 \f
678 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
679 ;; Modules
680 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
682 ;; Should return:
683 ;; '(("modules" . sub-modules) ("procs" . procedures) ("syntax" . macros) ("vars" . variables))
684 (define (geiser-module-exports module-name . rest)
685 (let* ((nodes (match-nodes module-name)))
686 (if (null? nodes)
687 '()
688 (let ((mod '())
689 (proc '())
690 (syn '())
691 (var '()))
692 (map
693 (lambda (node)
694 (let ((type (node-type node))
695 (name (node-id node))
696 (path (node-path node)))
697 (cond
698 ((memq type '(unit egg))
699 (set! mod (cons name mod)))
700 ((memq type '(procedure record setter class method))
701 (set! proc (cons name proc)))
702 ((memq type '(read syntax))
703 (set! syn (cons name syn)))
704 ((memq type '(parameter constant))
705 (set! var (cons name var))))))
706 nodes)
707 `(("modules" . ,mod)
708 ("procs" . ,proc)
709 ("syntax" . ,syn)
710 ("vars" . ,var))))))
712 ;; Returns the path for the file in which an egg or module was defined
714 (define (geiser-module-path module-name . rest)
715 #f)
717 ;; Returns:
718 ;; `(("file" . ,(module-path name)) ("line"))
720 (define (geiser-module-location name . rest)
721 #f)
722 \f
723 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
724 ;; Misc
725 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
727 (define (geiser-macroexpand form . rest)
728 (with-output-to-string
729 (lambda ()
730 (write (expand form)))))
732 ;; End module
733 )