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