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   (geiser-eval
  10    geiser-no-values
  11    geiser-newline
  12    geiser-start-server
  13    geiser-completions
  14    geiser-autodoc
  15    geiser-object-signature
  16    geiser-symbol-location
  17    geiser-symbol-documentation
  18    geiser-find-file
  19    geiser-add-to-load-path
  20    geiser-load-file
  21    geiser-compile-file
  22    geiser-compile
  23    geiser-module-exports
  24    geiser-module-path
  25    geiser-module-location
  26    geiser-module-completions
  27    geiser-macroexpand
  28    geiser-use-debug-log)
  29
  30   (import chicken scheme)
  31   (use
  32     apropos
  33     chicken-doc
  34     csi
  35     data-structures
  36     extras
  37     ports
  38     posix
  39     srfi-1
  40     srfi-13
  41     srfi-14
  42     srfi-18
  43     srfi-69
  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 #f))
 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 memo (make-parameter (make-hash-table)))
 223   (define (clear-memo) (hash-table-clear! (memo)))
 224   (define (memoize tag thunk)
 225     (let ((table (memo)))
 226       (if (hash-table-exists? table tag)
 227           (hash-table-ref table tag)
 228           (begin
 229             (hash-table-set! table tag (thunk))
 230             (memoize tag thunk)))))
 231
 232   (define debug-log (make-parameter #f))
 233   (define (write-to-log form)
 234     (when (geiser-use-debug-log)
 235       (when (not (debug-log))
 236         (debug-log (file-open "geiser.log" (+ open/wronly open/append open/text open/creat)))
 237         (set-file-position! (debug-log) 0 seek/end))
 238       (file-write (debug-log) (with-all-output-to-string (lambda () (write form) (newline))))
 239       (file-write (debug-log) "\n")))
 240
 241   (define (remove-internal-name-mangling sym)
 242     (let* ((sym (->string sym))
 243            (octothorpe-index (string-index-right sym #\#)))
 244       (if octothorpe-index
 245           (values (substring/shared sym (add1 octothorpe-index))
 246                   (substring/shared sym 0 octothorpe-index))
 247           (values sym '()))))
 248
 249   (define (string-has-prefix? s prefix)
 250     (let ((s-length (string-length s))
 251           (prefix-length (string-length prefix)))
 252       (and
 253        (< prefix-length s-length)
 254        (string-contains s prefix 0 prefix-length))))
 255
 256   ;; This really should be a chicken library function
 257   (define (write-exception exn)
 258     (define (write-call-entry call)
 259       (let ((type (vector-ref call 0))
 260             (line (vector-ref call 1)))
 261         (cond
 262          ((equal? type "<syntax>")
 263           (display (string-append type " ")) (write line) (newline))
 264          ((equal? type "<eval>")
 265           (display (string-append type "   ")) (write line) (newline)))))
 266
 267     (display (format "Error: (~s) ~s: ~s"
 268                      ((condition-property-accessor 'exn 'location) exn)
 269                      ((condition-property-accessor 'exn 'message) exn)
 270                      ((condition-property-accessor 'exn 'arguments) exn)))
 271     (newline)
 272     (display "Call history: ") (newline)
 273     (map write-call-entry ((condition-property-accessor 'exn 'call-chain) exn))
 274     (newline))
 275
 276   ;; And this should be a chicken library function as well
 277   (define (with-all-output-to-string thunk)
 278     (with-output-to-string
 279       (lambda ()
 280         (with-error-output-to-port
 281          (current-output-port)
 282          thunk))))
 283
 284   (define (maybe-call func val)
 285     (if val (func val) #f))
 286
 287   ;; Wraps output from geiser functions
 288   (define (call-with-result module thunk)
 289     (let* ((result (if #f #f))
 290            (output (if #f #f))
 291            (module (maybe-call (lambda (v) (find-module module)) module))
 292            (original-module (current-module)))
 293
 294       (set! output
 295             (handle-exceptions exn
 296              (with-all-output-to-string
 297               (lambda () (write-exception exn)))
 298              (with-all-output-to-string
 299               (lambda ()
 300                 (switch-module module)
 301                 (call-with-values thunk (lambda v (set! result v)))))))
 302
 303       (switch-module original-module)
 304
 305       (set! result
 306         (cond
 307          ((list? result)
 308           (map (lambda (v) (with-output-to-string (lambda () (write v)))) result))
 309          ((eq? result (if #f #t))
 310           (list output))
 311          (else
 312           (list (with-output-to-string (lambda () (write result)))))))
 313
 314       (let ((out-form
 315              `((result ,@result)
 316                (output . ,output))))
 317         (write out-form)
 318         (write-to-log '[[RESPONSE]])
 319         (write-to-log out-form))
 320
 321       (newline)))
 322
 323   (define (find-standards-with-symbol sym)
 324     (append
 325      (if (any (cut eq? <> sym) (geiser-r4rs-symbols))
 326          '(r4rs)
 327          '())
 328      (if (any (cut eq? <> sym) (geiser-r5rs-symbols))
 329          '(r5rs)
 330          '())
 331      (if (any (cut eq? <> sym) (geiser-r7rs-small-symbols))
 332          '(r7rs)
 333          '())
 334      (if (any (cut eq? <> sym) (geiser-chicken-builtin-symbols))
 335          '(chicken)
 336          '())
 337      (if (any (cut eq? <> sym) (geiser-chicken-crunch-symbols))
 338          '(crunch)
 339          '())))
 340
 341   ;; Locates any paths at which a particular symbol might be located
 342   (define (find-library-paths sym types)
 343     ;; Removes the given sym from the node path
 344     (define (remove-self sym path)
 345       (cond
 346        ((not (list? path)) path)
 347        ((null? path) path)
 348        ((null? (cdr path))
 349         (if (eq? (car path) sym)
 350             '()
 351             path))
 352        (else
 353         (cons (car path) (remove-self sym (cdr path))))))
 354
 355     (append
 356      (map
 357       (cut list <>)
 358       (find-standards-with-symbol sym))
 359      (map
 360       (lambda (node)
 361         (remove-self sym (node-path node)))
 362       (filter
 363        (lambda (n)
 364          (let ((type (node-type n)))
 365            (any (cut eq? type <>) types)))
 366        (match-nodes sym)))))
 367
 368   (define (make-module-list sym module-sym)
 369     (if (null? module-sym)
 370         (find-standards-with-symbol sym)
 371         (cons module-sym (find-standards-with-symbol sym))))
 372
 373   (define (fmt sym node)
 374     (let* ((entry-str (car node))
 375            (module (cadr node))
 376            (rest (cddr node))
 377            (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
 378       (cond
 379        ((equal? 'macro type)
 380         `(,entry-str ("args" (("required" <macro>)
 381                               ("optional" ...)
 382                               ("key")))
 383                      ("module" ,@(make-module-list sym module))))
 384        ((or (equal? 'variable type)
 385             (equal? 'constant type))
 386         (if (null? module)
 387             `(,entry-str ("value" . ,(eval sym)))
 388             (let* ((original-module (current-module))
 389                    (desired-module (find-module (string->symbol module)))
 390                    (value (begin (switch-module desired-module)
 391                                  (eval sym))))
 392               (switch-module original-module)
 393               `(,entry-str ("value" . ,value)
 394                            ("module" ,@(make-module-list sym module))))))
 395        (else
 396         (let ((reqs '())
 397               (opts '())
 398               (keys '())
 399               (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
 400
 401           (define (clean-arg arg)
 402             (let ((s (->string arg)))
 403               (substring/shared s 0 (string-skip-right s char-set:digit))))
 404
 405           (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
 406             (when (not (null? args))
 407               (cond
 408                ((or (pair? args) (list? args))
 409                 (cond
 410                  ((eq? '#!key (car args))
 411                   (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
 412                  ((eq? '#!optional (car args))
 413                   (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
 414                  (else
 415                   (begin
 416                     (cond
 417                      (reqs?
 418                       (set! reqs (append reqs (list (clean-arg (car args))))))
 419                      (opts?
 420                       (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
 421                      (keys?
 422                       (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
 423                     (collect-args (cdr args))))))
 424                (else
 425                 (set! opts (list (clean-arg args) '...))))))
 426
 427           (collect-args args)
 428
 429           `(,entry-str ("args" (("required" ,@reqs)
 430                                 ("optional" ,@opts)
 431                                 ("key" ,@keys)))
 432                        ("module" ,@(make-module-list sym module))))))))
 433
 434   ;; Builds a signature list from an identifier
 435   (define (find-signatures sym)
 436     (let ((str (->string sym)))
 437       (map
 438        (cut fmt sym <>)
 439        (filter
 440         (lambda (v)
 441           (eq? (car v) sym))
 442         (map
 443          (lambda (s)
 444            ;; Remove egg name and add module
 445            (let-values
 446                (((name module) (remove-internal-name-mangling (car s))))
 447              (cons (string->symbol name)
 448                    (cons (if (string? module) (string->symbol module) module)
 449                          (cdr s)))))
 450          (apropos-information-list sym #:macros? #t))))))
 451
 452   ;; Builds the documentation from Chicken Doc for a specific symbol
 453   (define (make-doc symbol #!optional (filter-for-type #f))
 454     (with-output-to-string
 455       (lambda ()
 456         (map (lambda (node)
 457                (display (string-append "= Node: " (->string (node-id node)) " " " =\n"))
 458                (describe node)
 459                (display "\n\n"))
 460              (filter
 461               (lambda (n)
 462                 (or (not filter-for-type)
 463                     (eq? (node-type n) filter-for-type)))
 464               (match-nodes symbol))))))
 465
 466 \f
 467 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 468 ;; Geiser core functions
 469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 470
 471   ;; Basically all non-core functions pass through geiser-eval
 472
 473   (define (geiser-eval module form . rest)
 474     ;; We can't allow nested module definitions in Chicken
 475     (define (form-has-module? form)
 476       (or (eq? (car form) 'module) (eq? (car form) 'define-library)))
 477
 478     (define (form-has-safe-geiser? form)
 479       (any (cut eq? (car form) <>)
 480            '(geiser-no-values geiser-newline geiser-start-server geiser-completions
 481              geiser-autodoc geiser-object-signature geiser-symbol-location
 482              geiser-symbol-documentation geiser-find-file geiser-add-to-load-path
 483              geiser-module-exports geiser-module-path geiser-module-location
 484              geiser-module-completions geiser-macroexpand geiser-use-debug-log)))
 485
 486     (when (and module
 487                (not (symbol? module)))
 488       (error "Module should be a symbol"))
 489
 490     ;; All calls start at toplevel
 491     (let* ((is-module? (form-has-module? form))
 492            (is-safe-geiser? (form-has-safe-geiser? form))
 493            (host-module (and (not is-module?)
 494                              (any (cut equal? module <>) (list-modules))
 495                              module))
 496            (thunk (lambda () (eval form))))
 497
 498       (write-to-log `[[REQUEST host-module ,host-module is-safe-geiser? ,is-safe-geiser?]])
 499       (write-to-log form)
 500
 501       (if is-safe-geiser?
 502           (call-with-result host-module (lambda () (memoize form thunk)))
 503           (begin
 504             (clear-memo)
 505             (call-with-result host-module thunk)))))
 506
 507   ;; Load a file
 508
 509   (define (geiser-load-file file)
 510     (let* ((file (if (symbol? file) (symbol->string file) file))
 511            (found-file (geiser-find-file #f file)))
 512       (call-with-result #f
 513        (lambda ()
 514          (when found-file
 515            (load found-file))))))
 516
 517   ;; The no-values identity
 518
 519   (define (geiser-no-values)
 520     (values))
 521 \f
 522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 523 ;; Miscellaneous
 524 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 525
 526   ;; Invoke a newline
 527
 528   (define (geiser-newline . rest)
 529     (newline))
 530
 531   ;; Spawn a server for remote repl access
 532
 533   (define (geiser-start-server . rest)
 534     (let* ((listener (tcp-listen 0))
 535            (port (tcp-listener-port listener)))
 536       (define (remote-repl)
 537         (receive (in out) (tcp-accept listener)
 538           (current-input-port in)
 539           (current-output-port out)
 540           (current-error-port out)
 541
 542           (repl)))
 543
 544       (thread-start! (make-thread remote-repl))
 545
 546       (write-to-log `(geiser-start-server . ,rest))
 547       (write-to-log `(port ,port))
 548
 549       (write `(port ,port))
 550       (newline)))
 551 \f
 552 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 553 ;; Completions, Autodoc and Signature
 554 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 555
 556   (define (geiser-completions prefix . rest)
 557     (let ((prefix (->string prefix))
 558           (unfiltered (map remove-internal-name-mangling
 559                            (apropos-list prefix #:macros? #t))))
 560       (filter (cut string-has-prefix? <> prefix) unfiltered)))
 561
 562   (define (geiser-module-completions prefix . rest)
 563     (let ((prefix (->string prefix)))
 564       (filter (cut string-has-prefix? <> prefix) (map ->string (list-modules)))))
 565
 566   (define (geiser-autodoc ids . rest)
 567     (cond
 568      ((null? ids) '())
 569      ((not (list? ids))
 570       (geiser-autodoc (list ids)))
 571      (else
 572       (let ((details (find-signatures (car ids))))
 573         (if (null? details)
 574             (geiser-autodoc (cdr ids))
 575             details)))))
 576
 577   (define (geiser-object-signature name object . rest)
 578     (let* ((sig (geiser-autodoc `(,name))))
 579       (if (null? sig) '() (car sig))))
 580
 581     ;; TODO: Divine some way to support this functionality
 582
 583   (define (geiser-symbol-location symbol . rest)
 584     '(("file") ("line")))
 585
 586   (define (geiser-symbol-documentation symbol . rest)
 587     (let* ((sig (find-signatures symbol)))
 588       `(("signature" ,@(car sig))
 589         ("docstring" . ,(make-doc symbol)))))
 590 \f
 591 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 592 ;; File and Buffer Operations
 593 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 594
 595   (define geiser-load-paths (make-parameter '()))
 596
 597   (define (geiser-find-file file . rest)
 598     (let ((paths (append '("" ".") (geiser-load-paths))))
 599       (define (try-find file paths)
 600         (cond
 601          ((null? paths) #f)
 602          ((file-exists? (string-append (car paths) file))
 603           (string-append (car paths) file))
 604          (else (try-find file (cdr paths)))))
 605       (try-find file paths)))
 606
 607   (define (geiser-add-to-load-path directory . rest)
 608     (let* ((directory (if (symbol? directory)
 609                           (symbol->string directory)
 610                           directory))
 611            (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory)))))
 612                           (string-append directory "/")
 613                           directory)))
 614       (call-with-result #f
 615        (lambda ()
 616          (when (directory-exists? directory)
 617            (geiser-load-paths (cons directory (geiser-load-paths))))))))
 618
 619   (define (geiser-compile-file file . rest)
 620     (let* ((file (if (symbol? file) (symbol->string file) file))
 621            (found-file (geiser-find-file file)))
 622       (call-with-result #f
 623        (lambda ()
 624          (when found-file
 625            (compile-file found-file))))))
 626
 627     ;; TODO: Support compiling regions
 628
 629   (define (geiser-compile form module . rest)
 630     (error "Chicken does not support compiling regions"))
 631 \f
 632 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 633 ;; Modules
 634 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 635
 636   ;; Should return:
 637   ;; '(("modules" . sub-modules) ("procs" . procedures) ("syntax" . macros) ("vars" . variables))
 638   (define (geiser-module-exports module-name . rest)
 639     (let* ((nodes (match-nodes module-name)))
 640       (if (null? nodes)
 641           '()
 642           (let ((mod '())
 643                 (proc '())
 644                 (syn '())
 645                 (var '()))
 646             (map
 647              (lambda (node)
 648                (let ((type (node-type node))
 649                      (name (node-id node))
 650                      (path (node-path node)))
 651                  (cond
 652                   ((memq type '(unit egg))
 653                    (set! mod (cons name mod)))
 654                   ((memq type '(procedure record setter class method))
 655                    (set! proc (cons name proc)))
 656                   ((memq type '(read syntax))
 657                    (set! syn (cons name syn)))
 658                   ((memq type '(parameter constant))
 659                    (set! var (cons name var))))))
 660              nodes)
 661             `(("modules" . ,mod)
 662               ("proces" . ,proc)
 663               ("syntax" . ,syn)
 664               ("vars" . ,var))))))
 665
 666   ;; Returns the path for the file in which an egg or module was defined
 667
 668   (define (geiser-module-path module-name . rest)
 669     #f)
 670
 671   ;; Returns:
 672   ;; `(("file" . ,(module-path name)) ("line"))
 673
 674   (define (geiser-module-location name . rest)
 675     #f)
 676 \f
 677 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 678 ;; Misc
 679 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 680
 681   (define (geiser-macroexpand form . rest)
 682     (with-output-to-string
 683       (lambda ()
 684         (write (expand form)))))
 685
 686 ;; End module
 687   )