scheme/chez/geiser/geiser.ss

   1 (library (geiser)
   2   (export geiser:eval
   3           geiser:completions
   4           geiser:module-completions
   5           geiser:autodoc
   6           geiser:no-values
   7           geiser:newline)
   8   (import (chezscheme))
   9
  10   (define string-prefix?
  11     (lambda (x y)
  12       (let ([n (string-length x)])
  13         (and (fx<= n (string-length y))
  14              (let prefix? ([i 0])
  15                (or (fx= i n)
  16                    (and (char=? (string-ref x i) (string-ref y i))
  17                         (prefix? (fx+ i 1)))))))))
  18
  19   (define (geiser:completions prefix . rest)
  20     rest
  21     (sort string-ci<?
  22           (filter (lambda (el)
  23                     (string-prefix? prefix el))
  24                   (map write-to-string (environment-symbols (interaction-environment))))))
  25
  26   (define (write-to-string x)
  27     (with-output-to-string
  28       (lambda ()
  29         (write x))))
  30
  31   (define (geiser:eval module form . rest)
  32     rest
  33     (let* ((try-eval (lambda (x . y)
  34                        (call/cc
  35                         (lambda (k)
  36                           (with-exception-handler
  37                               (lambda (e)
  38                                 (k e))
  39                             (lambda ()
  40                                     (if (null? y) (eval x)
  41                                         (eval x (car y)))
  42                                     ))))))
  43            (result-mid (call-with-values
  44                            (lambda () (if module
  45                                           (try-eval form (environment module))
  46                                           (try-eval form)))
  47                          (lambda (x . y)
  48                            (if (null? y)
  49                                x
  50                                (cons x y)))))
  51            (result result-mid)
  52            (error (if (condition? result-mid)
  53                       (cons 'error (list
  54                                     (cons 'key
  55                                           (with-output-to-string
  56                                             (lambda () (display-condition result-mid))))))
  57                       '())))
  58       (write `((result ,(write-to-string result))
  59                (output . "")
  60                ,error))
  61       (newline)))
  62
  63   (define (geiser:module-completions prefix . rest)
  64     (define (substring? s1 s2)
  65       (let ([n1 (string-length s1)] [n2 (string-length s2)])
  66         (let loop2 ([i2 0])
  67           (let loop1 ([i1 0] [j i2])
  68             (if (fx= i1 n1)
  69                 i2
  70                 (and (not (fx= j n2))
  71                      (if (char=? (string-ref s1 i1) (string-ref s2 j))
  72                          (loop1 (fx+ i1 1) (fx+ j 1))
  73                          (loop2 (fx+ i2 1)))))))))
  74     (filter (lambda (el)
  75               (substring? prefix el))
  76             (map write-to-string (library-list))))
  77
  78   (define (procedure-parameter-list p)
  79     ;; same as (inspect object), then hitting c
  80     (let ((s (((inspect/object p) 'code) 'source)))
  81       (if s
  82           (let ((form (s 'value)))
  83             (if (and (list? form)
  84                      (> (length form) 2)
  85                      (eq? (car form) 'lambda))
  86                 (cadr form)
  87                 #f))
  88           #f)))
  89
  90   (define (operator-arglist operator)
  91     (let ((binding (eval operator)))
  92       (if binding
  93           (let ((arglist (procedure-parameter-list binding)))
  94             (let loop ((arglist arglist)
  95                        (optionals? #f)
  96                        (required '())
  97                        (optional '()))
  98               (cond ((null? arglist)
  99                      `(,operator ("args" (("required" ,@(reverse required))
 100                                           ("optional" ,@(reverse optional))
 101                                           ("key")
 102                                           ;; ("module" ,module)
 103                                           ))))
 104                     ((symbol? arglist)
 105                      (loop '()
 106                            #t
 107                            required
 108                            (cons "..." (cons arglist optional))))
 109                     (else
 110                      (loop
 111                       (cdr arglist)
 112                       optionals?
 113                       (if optionals? required (cons (car arglist) required))
 114                       (if optionals? (cons (car arglist) optional) optional))))))
 115           '())))
 116
 117   (define (geiser:autodoc ids . rest)
 118     (cond ((null? ids) '())
 119           ((not (list? ids))
 120            (geiser:autodoc (list ids)))
 121           ((not (symbol? (car ids)))
 122            (geiser:autodoc (cdr ids)))
 123           (else
 124            (map (lambda (id)
 125                   (operator-arglist id))
 126                 ids))))
 127
 128   (define (geiser:no-values)
 129     #f)
 130
 131   (define (geiser:newline)
 132     #f))