scheme/chicken/geiser/emacs.scm

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