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