summaryrefslogtreecommitdiff
path: root/scheme/chicken/geiser/emacs.scm
blob: 74117bad7e3bbda7c3992e099e1f608eb2d55c60 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
;; Copyright (C) 2015 Daniel J Leslie

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.

(module geiser
  ;; A bunch of these needn't be toplevel functions
  (geiser-eval
   geiser-no-values
   geiser-newline
   geiser-start-server
   geiser-completions
   geiser-autodoc
   geiser-object-signature
   geiser-symbol-location
   geiser-symbol-documentation
   geiser-find-file
   geiser-add-to-load-path
   geiser-load-file
   geiser-compile-file
   geiser-compile
   geiser-module-exports
   geiser-module-path
   geiser-module-location
   geiser-module-completions
   geiser-macroexpand
   make-geiser-toplevel-bindings)

  ;; Necessary built in units
  (import chicken
          scheme
          extras
          data-structures
          ports
          csi
          irregex
          srfi-1
          posix
          utils)

  (use apropos
       regex
       chicken-doc
       tcp
       srfi-18)

  (define use-debug-log #f)

  (if use-debug-log
   (use posix))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Symbol lists
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define geiser-r4rs-symbols
    (make-parameter
     '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr
           caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar
           caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar
           cddadr cdddar cddddr set-car! set-cdr! null? list? list length
           list-tail list-ref append reverse memq memv member assq assv assoc
           symbol? symbol->string string->symbol number? integer? exact? real?
           complex? inexact? rational? zero? odd? even? positive? negative?
           max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs
           floor ceiling truncate round exact->inexact inexact->exact exp log
           expt sqrt sin cos tan asin acos atan number->string string->number
           char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<?
           char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace?
           char-numeric? char-upper-case? char-lower-case? char-upcase
           char-downcase char->integer integer->char string? string=? string>?
           string<? string>=? string<=? string-ci=? string-ci<? string-ci>?
           string-ci>=? string-ci<=?  make-string string-length string-ref
           string-set! string-append string-copy string->list list->string
           substring string-fill! vector? make-vector vector-ref vector-set!
           string vector vector-length vector->list list->vector vector-fill!
           procedure? map for-each apply force call-with-current-continuation
           input-port? output-port? current-input-port current-output-port
           call-with-input-file call-with-output-file open-input-file
           open-output-file close-input-port close-output-port load
           read eof-object? read-char peek-char write display write-char
           newline with-input-from-file with-output-to-file eval char-ready?
           imag-part real-part magnitude numerator denominator
           scheme-report-environment null-environment interaction-environment
           else)))

  (define geiser-r5rs-symbols
    (make-parameter
     '(abs acos and angle append apply asin assoc assq assv atan begin
           boolean? caar cadr call-with-current-continuation
           call-with-input-file call-with-output-file call-with-values
           car case cdddar cddddr cdr ceiling char->integer char-alphabetic?
           char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase
           char-lower-case? char-numeric? char-ready? char-upcase
           char-upper-case? char-whitespace? char<=? char<? char=? char>=?
           char>? char? close-input-port close-output-port complex? cond cons
           cos current-input-port current-output-port define define-syntax
           delay denominator display do dynamic-wind else eof-object? eq?
           equal? eqv? eval even? exact->inexact exact? exp expt floor
           for-each force gcd if imag-part inexact->exact inexact? input-port?
           integer->char integer? interaction-environment lambda lcm length
           let let* let-syntax letrec letrec-syntax list list->string
           list->vector list-ref list-tail list? load log magnitude make-polar
           make-rectangular make-string make-vector map max member memq memv
           min modulo negative? newline not null-environment null?
           number->string number? numerator odd? open-input-file
           open-output-file or output-port? pair? peek-char port? positive?
           procedure? quasiquote quote quotient rational? rationalize read
           read-char real-part real? remainder reverse round
           scheme-report-environment set! set-car! set-cdr! setcar sin sqrt
           string string->list string->number string->symbol string-append
           string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
           string-copy string-fill! string-length string-ref string-set!
           string<=? string<? string=? string>=? string>? string? substring
           symbol->string symbol? syntax-rules tan transcript-off transcript-on
           truncate values vector vector->list vector-fill! vector-length
           vector-ref vector-set! vector? with-input-from-file with-output-to-file
           write write-char zero?)))

  (define geiser-r7rs-small-symbols
    (make-parameter
     '(* + - ... / < <= = => > >= abs and append apply assoc assq
         assv begin binary-port? boolean=? boolean? bytevector
         bytevector-append bytevector-copy bytevector-copy! bytevector-length
         bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
         call-with-current-continuation call-with-port call-with-values call/cc
         car case cdar cddr cdr ceiling char->integer char-ready? char<=?
         char<? char=? char>=? char>? char? close-input-port
         close-output-port close-port complex? cond cond-expand cons
         current-error-port current-input-port current-output-port
         define define-record-type define-syntax define-values denominator do
         dynamic-wind else eof-object? equal? error error-object-message
         even? exact-integer-sqrt exact? features floor floor-remainder
         flush-output-port gcd get-output-string if include-ci inexact?
         input-port? integer? lcm let let*-values let-values letrec* list
         list->vector list-ref list-tail make-bytevector make-parameter
         make-vector max memq min negative? not number->string numerator
         open-input-bytevector open-output-bytevector or output-port?
         parameterize peek-u8 positive? quasiquote quotient raise-continuable
         rationalize read-bytevector! read-error? read-string real? reverse
         set! set-cdr! string string->number string->utf8 string-append
         eof-object eq? eqv? error-object-irritants error-object? exact
         exact-integer? expt file-error? floor-quotient floor/ for-each
         get-output-bytevector guard include inexact input-port-open?
         integer->char lambda length let* let-syntax letrec letrec-syntax
         list->string list-copy list-set! list? make-list make-string map
         member memv modulo newline null? number? odd? open-input-string
         open-output-string output-port-open? pair? peek-char port?
         procedure? quote raise rational? read-bytevector read-char read-line
         read-u8 remainder round set-car! square string->list string->symbol
         string->vector string-copy string-copy! string-for-each string-map
         string-set! string<? string>=? string? symbol->string symbol?
         syntax-rules truncate truncate-remainder u8-ready? unquote
         utf8->string vector vector->string vector-copy vector-fill!
         vector-length vector-ref vector? with-exception-handler write-char
         write-u8 string-fill! string-length string-ref string<=?
         string=? string>? substring symbol=? syntax-error textual-port?
         truncate-quotient truncate/ unless unquote-splicing values
         vector->list vector-append vector-copy! vector-for-each vector-map
         vector-set! when write-bytevector write-string zero?)))

  (define geiser-chicken-builtin-symbols
    (make-parameter
     '(and-let* assume compiler-typecase cond-expand condition-case cut cute declare define-constant
                define-inline define-interface define-record define-record-type define-specialization
                define-syntax-rule define-type define-values dotimes ecase fluid-let foreign-lambda
                foreign-lambda* foreign-primitive foreign-safe-lambda foreign-safe-lambda* functor
                handle-exceptions import let*-values let-location let-optionals let-optionals*
                let-values letrec* letrec-values match-letrec module parameterize regex-case
                require-extension select set! unless use when with-input-from-pipe match
                match-lambda match-lambda* match-let match-let* receive)))

  (define geiser-chicken-crunch-symbols
    (make-parameter
     '(cond-expand when unless switch rec not eq? eqv? equal? + - * / = > < >= <= abs acos asin atan ceiling cos display even? exact? exact->inexact exp expt floor inexact? inexact->exact integer? log max min modulo negative? odd? positive? quotient remainder round sin sqrt tan truncate zero? char=? char>? char<? char>=? char<=? char->integer char-alphabetic? char-ci=? char-ci>? char-ci<? char-ci>=? char-ci<=? char-downcase char-lower-case? char-numeric? char-upper-case? char-upcase char-whitespace? integer->char number->string make-string string=? string>? string<? string>=? string<=? string->number string-ci=? string-ci>? string-ci<? string-ci>=? string-ci<=? string-append string-copy string-fill! string-length string-ref string-set! substring display newline write-char add1 atan2 arithmetic-shift bitwise-and bitwise-ior bitwise-not bitwise-xor sub1 f32vector-length f32vector-ref f32vector-set! f64vector-length f64vector-ref f64vector-set! make-f32vector make-f64vector make-s16vector make-s32vector make-s8vector make-u16vector make-u32vector make-u8vector s16vector-length s16vector-ref s16vector-set! s32vector-length s32vector-ref s32vector-set! s8vector-length s8vector-ref s8vector-set! subf32vector subf64vector subs16vector subs32vector subs8vector subu16vector subu32vector subu8vector u16vector-length u16vector-ref u16vector-set! u32vector-length u32vector-ref u32vector-set! u8vector-length u8vector-ref u8vector-set! blob->f32vector blob->f32vector/shared blob->f64vector blob->f64vector/shared blob->s16vector blob->s16vector/shared blob->s32vector blob->s32vector/shared blob->s8vector blob->s8vector/shared blob->string blob->string/shared blob->u16vector blob->u16vector/shared blob->u32vector blob->u32vector/shared blob->u8vector blob->u8vector/shared f32vector->blob f32vector->blob/shared f64vector->blob f64vector->blob/shared s16vector->blob s16vector->blob/shared s32vector->blob s32vector->blob/shared s8vector->blob s8vector->blob/shared string->blob string->blob/shared u16vector->blob u16vector->blob/shared u32vector->blob u32vector->blob/shared u8vector->blob u8vector->blob/shared flush-output void error exit argc argv-ref pointer-u8-ref pointer-s8-ref pointer-u16-ref pointer-s16-ref pointer-u32-ref pointer-s32-ref pointer-f32-ref pointer-f64-ref pointer-u8-set! pointer-s8-set! pointer-u16-set! pointer-s16-set! pointer-u32-set! pointer-s32-set! pointer-f32-set! pointer-f64-set!)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Utilities
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define find-module ##sys#find-module)
  (define current-module ##sys#current-module)
  (define switch-module ##sys#switch-module)
  (define module-name ##sys#module-name)
  (define (list-modules) (map car ##sys#module-table))

  (define (write-to-log form) #f)
  (define debug-log (make-parameter #f))

  (if use-debug-log
   (begin
     (define (write-to-log form)
       (when (not (debug-log))
         (debug-log (file-open "~/geiser-log.txt" (+ open/wronly open/append open/text open/creat)))
         (set-file-position! (debug-log) 0 seek/end))
       (file-write (debug-log) (with-all-output-to-string (lambda () (write form) (newline))))
       (file-write (debug-log) "\n"))))

  ;; This really should be a chicken library function
  (define (write-exception exn)
    (define (write-call-entry call)
      (let ((type (vector-ref call 0))
            (line (vector-ref call 1)))
        (cond
         ((equal? type "<syntax>")
          (display (string-append type " ")) (write line) (newline))
         ((equal? type "<eval>")
          (display (string-append type "   ")) (write line) (newline)))))

    (display (format "Error: (~s) ~s: ~s"
                     ((condition-property-accessor 'exn 'location) exn)
                     ((condition-property-accessor 'exn 'message) exn)
                     ((condition-property-accessor 'exn 'arguments) exn)))
    (newline)
    (display "Call history: ") (newline)
    (map write-call-entry ((condition-property-accessor 'exn 'call-chain) exn))
    (newline))

  ;; And this should be a chicken library function as well
  (define (with-all-output-to-string thunk)
    (with-output-to-string
      (lambda ()
        (with-error-output-to-port
         (current-output-port)
         thunk))))

  (define (maybe-call func val)
    (if val (func val) #f))

  (define (make-apropos-regex prefix)
    (string-append "^([^#]+#)*" (regexp-escape prefix)))

  (define (describe-symbol sym #!key (exact? #f))
    (let* ((str (->string sym))
           (found (apropos-information-list (regexp (make-apropos-regex str)) #:macros? #t)))
      (delete-duplicates
       (if exact?
           (filter (lambda (v)
                     (equal? str (string-substitute ".*#([^#]+)" "\\1" (symbol->string (car v)))))
                   found)
           found))))

  ;; Wraps output from geiser functions
  (define (call-with-result module thunk)
    (let* ((result (if #f #f))
           (output (if #f #f))
           (module (maybe-call (lambda (v) (find-module module)) module))
           (original-module (current-module)))

      (set! output
            (handle-exceptions exn
             (with-all-output-to-string
              (lambda () (write-exception exn)))
             (with-all-output-to-string
              (lambda ()
                (switch-module module)
                (call-with-values thunk (lambda v (set! result v)))))))

      (switch-module original-module)

      (set! result
        (cond
         ((list? result)
          (map (lambda (v) (with-output-to-string (lambda () (pretty-print v)))) result))
         ((eq? result (if #f #t))
          (list output))
         (else
          (list (with-output-to-string (lambda () (pretty-print result)))))))

      (let ((out-form
             `((result ,@result)
               (output . ,output))))
        (write out-form)
        (write-to-log out-form))

      (newline)))

  (define geiser-toplevel-functions (make-parameter '()))

  ;; This macro aids in the creation of toplevel definitions for the interpreter which are also available to code
  ;; toplevel passes parameters via the current-input-port, and so in order to make the definition behave nicely
  ;; in both usage contexts I defined a (get-arg) function which iteratively pulls arguments either from the
  ;; input port or from the variable arguments, depending on context.
  (define-syntax define-toplevel-for-geiser
    (lambda (f r c)
      (let* ((name (cadr f))
             (body (cddr f)))
        `(begin
           (,(r 'define) (,name . !!args)
            (,(r 'define) !!read-arg (null? !!args))
            (,(r 'define) (get-arg)
             (if !!read-arg
                 (read)
                 (let ((arg (car !!args)))
                   (set! !!args (cdr !!args))
                   arg)))
            (begin ,@body))
           (,(r 'geiser-toplevel-functions) (cons (cons ',name ,name) (geiser-toplevel-functions)))))))

  (define (find-standards-with-symbol sym)
    (append
     (if (any (cut eq? <> sym) (geiser-r4rs-symbols))
         '(r4rs)
         '())
     (if (any (cut eq? <> sym) (geiser-r5rs-symbols))
         '(r5rs)
         '())
     (if (any (cut eq? <> sym) (geiser-r7rs-small-symbols))
         '(r7rs)
         '())
     (if (any (cut eq? <> sym) (geiser-chicken-builtin-symbols))
         '(chicken)
         '())
     (if (any (cut eq? <> sym) (geiser-chicken-crunch-symbols))
	 '(crunch)
	 '())))

  ;; Locates any paths at which a particular symbol might be located
  (define (find-library-paths sym types)
    ;; Removes the given sym from the node path
    (define (remove-self sym path)
      (cond
       ((not (list? path)) path)
       ((null? path) path)
       ((null? (cdr path))
        (if (eq? (car path) sym)
            '()
            path))
       (else
        (cons (car path) (remove-self sym (cdr path))))))

    (append
     (map
      (cut list <>)
      (find-standards-with-symbol sym))
     (map
      (lambda (node)
        (remove-self sym (node-path node)))
      (filter
       (lambda (n)
         (let ((type (node-type n)))
           (any (cut eq? type <>) types)))
       (match-nodes sym)))))

  ;; Builds a signature list from an identifier
  (define (find-signatures toplevel-module sym)
    (define str (->string sym))

    (define (make-module-list sym module-sym)
      (if (null? module-sym)
          (find-standards-with-symbol sym)
          (cons module-sym (find-standards-with-symbol sym))))

    (define (fmt node)
      (let* ((entry-str (car node))
             (module (cadr node))
             (rest (cddr node))
             (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
        (cond
         ((equal? 'macro type)
          `(,entry-str ("args" (("required" <macro>)
                                ("optional" ...)
                                ("key")))
                       ("module" ,@(make-module-list sym module))))
         ((or (equal? 'variable type)
              (equal? 'constant type))
          (if (null? module)
              `(,entry-str ("value" . ,(eval sym)))
              (let* ((original-module (current-module))
                     (desired-module (find-module (string->symbol module)))
                     (value (begin (switch-module desired-module)
                                   (eval sym))))
                (switch-module original-module)
                `(,entry-str ("value" . ,value)
                             ("module" ,@(make-module-list sym module))))))
         (else
          (let ((reqs '())
                (opts '())
                (keys '())
                (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))

            (define (clean-arg arg)
              (string->symbol (string-substitute "(.*[^0-9]+)[0-9]+" "\\1" (->string arg))))

            (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
              (when (not (null? args))
                (cond
                 ((or (pair? args) (list? args))
                  (cond
                   ((eq? '#!key (car args))
                    (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
                   ((eq? '#!optional (car args))
                    (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
                   (else
                    (begin
                      (cond
                       (reqs?
                        (set! reqs (append reqs (list (clean-arg (car args))))))
                       (opts?
                        (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
                       (keys?
                        (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
                      (collect-args (cdr args))))))
                 (else
                  (set! opts (list (clean-arg args) '...))))))

            (collect-args args)

            `(,entry-str ("args" (("required" ,@reqs)
                                  ("optional" ,@opts)
                                  ("key" ,@keys)))
                         ("module" ,@(make-module-list sym module))))))))

    (define (find sym)
      (map
       (lambda (s)
         ;; Remove egg name and add module
         (let* ((str (symbol->string (car s)))
                (name (string-substitute ".*#([^#]+)" "\\1" str))
                (module
                    (if (string-search "#" str)
                        (string-substitute "^([^#]+)#[^#]+$" "\\1" str)
                        '())))
           (cons name (cons module (cdr s)))))
       (describe-symbol sym exact?: #t)))

    (map fmt (find sym)))

  ;; Builds the documentation from Chicken Doc for a specific symbol
  (define (make-doc symbol #!optional (filter-for-type #f))
    (with-output-to-string
      (lambda ()
        (map (lambda (node)
               (display (string-append "= Node: " (->string (node-id node)) " " " =\n"))
               (describe node)
               (display "\n\n"))
             (filter
              (lambda (n)
                (or (not filter-for-type)
                    (eq? (node-type n) filter-for-type)))
              (match-nodes symbol))))))

  (define (make-geiser-toplevel-bindings)
    (map
     (lambda (pair)
       (toplevel-command (car pair) (cdr pair)))
     (geiser-toplevel-functions)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Geiser toplevel functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Basically all non-core functions pass through geiser-eval

  (define-toplevel-for-geiser geiser-eval
    ;; We can't allow nested module definitions in Chicken
    (define (form-has-module? form)
      (let ((reg "\\( *module +|\\( *define-library +"))
        (string-search reg form)))

    ;; Chicken doesn't support calling toplevel functions through eval,
    ;; So when we're in a module or calling into an environment we have
    ;; to first call from the toplevel environment and then switch
    ;; into the desired env.
    (define (form-has-geiser? form)
      (let ((reg "\\( *geiser-"))
        (string-search reg form)))

    ;; All calls start at toplevel
    (let* ((module (get-arg))
           (form (get-arg))
           (str-form (format "~s" form))
           (is-module? (form-has-module? str-form))
           (is-geiser? (form-has-geiser? str-form))
           (host-module (and (not is-module?)
                             (not is-geiser?)
                             (any (cut equal? module <>) (list-modules))
                             module)))

      (when (and module (not (symbol? module)))
        (error "Module should be a symbol"))

      ;; Inject the desired module as the first parameter
      (when is-geiser?
        (let ((module (maybe-call (lambda (v) (symbol->string module)) module)))
          (set! form (cons (car form) (cons module (cdr form))))))

      (define (thunk)
        (eval form))

      (write-to-log form)

      (call-with-result host-module thunk)))

  ;; Load a file

  (define-toplevel-for-geiser geiser-load-file
    (let* ((file (get-arg))
           (file (if (symbol? file) (symbol->string file) file))
           (found-file (geiser-find-file #f file)))
      (call-with-result #f
       (lambda ()
         (when found-file
           (load found-file))))))

  ;; The no-values identity

  (define-toplevel-for-geiser geiser-no-values
    (values))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Invoke a newline

  (define (geiser-newline . rest)
    (newline))

  ;; Spawn a server for remote repl access

  (define (geiser-start-server . rest)
    (let* ((listener (tcp-listen 0))
           (port (tcp-listener-port listener)))
      (define (remote-repl)
        (receive (in out) (tcp-accept listener)
          (current-input-port in)
          (current-output-port out)
          (current-error-port out)

          (repl)))

      (thread-start! (make-thread remote-repl))

      (write-to-log `(geiser-start-server . ,rest))
      (write-to-log `(port ,port))

      (write `(port ,port))
      (newline)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Completions, Autodoc and Signature
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (geiser-completions toplevel-module prefix . rest)
    ;; We search both toplevel definitions and module definitions
    (let* ((prefix (if (symbol? prefix) (symbol->string prefix) prefix))
           (re (regexp (make-apropos-regex prefix))))
      (sort! (map (lambda (sym)
                    ;; Strip out everything before the prefix
                    (string-substitute (string-append ".*(" (regexp-escape prefix) ".*)") "\\1" (symbol->string sym)))
                  (append (apropos-list re #:macros? #t)
                          (geiser-module-completions toplevel-module prefix)))
             string<?)))

  (define (geiser-module-completions toplevel-module prefix . rest)
    (let* ((match (string-append "^" (regexp-escape prefix))))
      (filter (lambda (v) (string-search match (symbol->string v)))
              (list-modules))))

  (define (geiser-autodoc toplevel-module ids . rest)
    (define (generate-details sym)
      (find-signatures toplevel-module sym))

    (if (list? ids)
        (foldr append '()
               (map generate-details ids))
        '()))

  (define (geiser-object-signature toplevel-module name object . rest)
    (let* ((sig (geiser-autodoc toplevel-module `(,name))))
      (if (null? sig) '() (car sig))))

    ;; TODO: Divine some way to support this functionality

  (define (geiser-symbol-location toplevel-module symbol . rest)
    '(("file") ("line")))

  (define (geiser-symbol-documentation toplevel-module symbol . rest)
    (let* ((sig (find-signatures toplevel-module symbol)))
      `(("signature" ,@(car sig))
        ("docstring" . ,(make-doc symbol)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File and Buffer Operations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define geiser-load-paths (make-parameter '()))

  (define (geiser-find-file toplevel-module file . rest)
    (let ((paths (append '("" ".") (geiser-load-paths))))
      (define (try-find file paths)
        (cond
         ((null? paths) #f)
         ((file-exists? (string-append (car paths) file))
          (string-append (car paths) file))
         (else (try-find file (cdr paths)))))
      (try-find file paths)))

  (define (geiser-add-to-load-path toplevel-module directory . rest)
    (let* ((directory (if (symbol? directory)
                          (symbol->string directory)
                          directory))
           (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory)))))
                          (string-append directory "/")
                          directory)))
      (call-with-result #f
       (lambda ()
         (when (directory-exists? directory)
           (geiser-load-paths (cons directory (geiser-load-paths))))))))

  (define (geiser-compile-file toplevel-module file . rest)
    (let* ((file (if (symbol? file) (symbol->string file) file))
           (found-file (geiser-find-file toplevel-module file)))
      (call-with-result #f
       (lambda ()
         (when found-file
           (compile-file found-file))))))

    ;; TODO: Support compiling regions

  (define (geiser-compile toplevel-module form module . rest)
    (error "Chicken does not support compiling regions"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Modules
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Should return:
  ;; '(("modules" . sub-modules) ("procs" . procedures) ("syntax" . macros) ("vars" . variables))
  (define (geiser-module-exports toplevel-module module-name . rest)
    (let* ((nodes (match-nodes module-name)))
      (if (null? nodes)
          '()
          (let ((mod '())
                (proc '())
                (syn '())
                (var '()))
            (map
             (lambda (node)
               (let ((type (node-type node))
                     (name (node-id node))
                     (path (node-path node)))
                 (cond
                  ((memq type '(unit egg))
                   (set! mod (cons name mod)))
                  ((memq type '(procedure record setter class method))
                   (set! proc (cons name proc)))
                  ((memq type '(read syntax))
                   (set! syn (cons name syn)))
                  ((memq type '(parameter constant))
                   (set! var (cons name var))))))
             nodes)
            `(("modules" . ,mod)
              ("proces" . ,proc)
              ("syntax" . ,syn)
              ("vars" . ,var))))))

  ;; Returns the path for the file in which an egg or module was defined

  (define (geiser-module-path toplevel-module module-name . rest)
    #f)

  ;; Returns:
  ;; `(("file" . ,(module-path name)) ("line"))

  (define (geiser-module-location toplevel-module name . rest)
    #f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Misc
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (geiser-macroexpand toplevel-module form . rest)
    (with-output-to-string
      (lambda ()
        (pretty-print (expand form)))))

;; End module
  )

(import geiser)
(make-geiser-toplevel-bindings)