diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/geiser/geiser.ss | 155 | ||||
| -rw-r--r-- | src/geiser/test.ss | 120 |
2 files changed, 275 insertions, 0 deletions
diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss new file mode 100644 index 0000000..33d1b39 --- /dev/null +++ b/src/geiser/geiser.ss @@ -0,0 +1,155 @@ +(library (geiser) + (export geiser:eval + geiser:completions + geiser:module-completions + geiser:autodoc + geiser:no-values + geiser:load-file + geiser:newline + geiser:macroexpand) + (import (chezscheme)) + + (define (last-index-of str-list char idx last-idx) + (if (null? str-list) + last-idx + (last-index-of (cdr str-list) char (+ 1 idx) (if (char=? char (car str-list)) idx last-idx)))) + + (define (obj-file-name name) + (let ((idx (last-index-of (string->list name) #\. 0 -1))) + (if (= idx -1) + (string-append name ".so") + (string-append (substring name 0 idx) ".so")))) + + (define (geiser:load-file filename) + (let ((output-filename (obj-file-name filename))) + (maybe-compile-file filename output-filename) + (load output-filename))) + + (define string-prefix? + (lambda (x y) + (let ([n (string-length x)]) + (and (fx<= n (string-length y)) + (let prefix? ([i 0]) + (or (fx= i n) + (and (char=? (string-ref x i) (string-ref y i)) + (prefix? (fx+ i 1))))))))) + + (define (geiser:completions prefix . rest) + rest + (sort string-ci<? + (filter (lambda (el) + (string-prefix? prefix el)) + (map write-to-string (environment-symbols (interaction-environment)))))) + + (define (write-to-string x) + (with-output-to-string + (lambda () + (write x)))) + + (define (geiser:eval module form . rest) + rest + (let ((output-string (open-output-string))) + (write + (call/cc + (lambda (k) + (with-exception-handler + (lambda (e) + (k `((result "") + (output . ,(with-output-to-string + (lambda () + (display-condition e)))) + (error (key . chez-error-message))))) + (lambda () + (call-with-values + ;; evaluate form, allow for multiple return values, + ;; and capture output in output-string. + (lambda () + (parameterize ((current-output-port output-string)) + (if module + (eval form (environment module)) + (eval form)))) + (lambda result + `((result ,(with-output-to-string + (lambda () + (pretty-print + (if (null? (cdr result)) (car result) result))))) + (output . ,(get-output-string output-string)))))))))) + (newline) + (close-output-port output-string))) + + (define (geiser:module-completions prefix . rest) + (define (substring? s1 s2) + (let ([n1 (string-length s1)] [n2 (string-length s2)]) + (let loop2 ([i2 0]) + (let loop1 ([i1 0] [j i2]) + (if (fx= i1 n1) + i2 + (and (not (fx= j n2)) + (if (char=? (string-ref s1 i1) (string-ref s2 j)) + (loop1 (fx+ i1 1) (fx+ j 1)) + (loop2 (fx+ i2 1))))))))) + (filter (lambda (el) + (substring? prefix el)) + (map write-to-string (library-list)))) + + (define (procedure-parameter-list p) + ;; same as (inspect object), then hitting c + (let ((s (((inspect/object p) 'code) 'source))) + (if s + (let ((form (s 'value))) + (if (and (list? form) + (> (length form) 2) + (eq? (car form) 'lambda)) + (cadr form) + #f)) + #f))) + + (define (operator-arglist operator) + (let ((binding (eval operator))) + (if binding + (let ((arglist (procedure-parameter-list binding))) + (let loop ((arglist arglist) + (optionals? #f) + (required '()) + (optional '())) + (cond ((null? arglist) + `(,operator ("args" (("required" ,@(reverse required)) + ("optional" ,@(reverse optional)) + ("key") + ;; ("module" ,module) + )))) + ((symbol? arglist) + (loop '() + #t + required + (cons "..." (cons arglist optional)))) + (else + (loop + (cdr arglist) + optionals? + (if optionals? required (cons (car arglist) required)) + (if optionals? (cons (car arglist) optional) optional)))))) + '()))) + + (define (geiser:autodoc ids . rest) + (cond ((null? ids) '()) + ((not (list? ids)) + (geiser:autodoc (list ids))) + ((not (symbol? (car ids))) + (geiser:autodoc (cdr ids))) + (else + (map (lambda (id) + (operator-arglist id)) + ids)))) + + (define (geiser:no-values) + #f) + + (define (geiser:newline) + #f) + + (define (geiser:macroexpand form . rest) + (with-output-to-string + (lambda () + (pretty-print + (syntax->datum (expand form))))))) diff --git a/src/geiser/test.ss b/src/geiser/test.ss new file mode 100644 index 0000000..2407448 --- /dev/null +++ b/src/geiser/test.ss @@ -0,0 +1,120 @@ +(import (geiser) + (chezscheme)) + +(define-syntax assert-equal + (syntax-rules () + ((_ a b) + (if (equal? a b) + #t + (begin + (display (format "failed assertion `~a' == `~a'" a b)) + (assert (equal? a b))))))) + +(define-syntax get-result + (syntax-rules () + ((_ form) + (with-output-to-string + (lambda () + (geiser:eval #f form)))))) + +(define-syntax do-test + (syntax-rules () + ((_ form result) + (assert + (equal? + (get-result form) + result))))) + +(define-syntax do-test-macroexpand + (syntax-rules () + ((_ form result) + (assert + (equal? (geiser:macroexpand form) + result))))) + +(define-syntax test-or + (syntax-rules () + ((_ x) x) + ((_ x xs ...) + (if x + x + (test-or xs ...))))) + +(do-test-macroexpand + '(test-or 1) + '1) + +(do-test-macroexpand + '(test-or 1 2) + '(if 1 1 2)) + +;; (something-doesnot-exist) +;;=> Error: Exception: variable something-doesnot-exist is not bound +(do-test + '(something-doesnot-exist) + "((result \"\") (output . \"\") (error (key . \"Exception: variable something-doesnot-exist is not bound\")))\n" + ) + +;; (make-violation) +;;=> #<condition &violation> +(do-test + '(make-violation) + "((result \"#<condition &violation>\\n\") (output . \"\"))\n") + +;; (values 1 2 3) +;;==> (1 2 3) +(do-test + '(values 1 2 3) + "((result \"(1 2 3)\\n\") (output . \"\"))\n") + +;; 1 +;;=> 1 +(do-test '1 "((result \"1\\n\") (output . \"\"))\n") + + +;; '(case-lambda +;; [(x1 x2) (+ x1 x2)] +;; [(x1 x2 x3) (+ (+ x1 x2) x3)] +;; [(x1 x2 . rest) +;; ((letrec ([loop (lambda (x1 x2 rest) +;; (let ([x (+ x1 x2)]) +;; (if (null? rest) +;; x +;; (loop x (car rest) (cdr rest)))))]) +;; loop) +;; x1 +;; x2 +;; rest)] +;; [(x1) (+ x1)] +;; [() (+)]) +#|=> (case-lambda + [(x1 x2) (+ x1 x2)] + [(x1 x2 x3) (+ (+ x1 x2) x3)] + [(x1 x2 . rest) + ((letrec ([loop (lambda (x1 x2 rest) + (let ([x (+ x1 x2)]) + (if (null? rest) + x + (loop x (car rest) (cdr rest)))))]) + loop) + x1 + x2 + rest)] + [(x1) (+ x1)] + [() (+)]) + |# +(do-test (quote '(case-lambda + [(x1 x2) (+ x1 x2)] + [(x1 x2 x3) (+ (+ x1 x2) x3)] + [(x1 x2 . rest) + ((letrec ([loop (lambda (x1 x2 rest) + (let ([x (+ x1 x2)]) + (if (null? rest) + x + (loop x (car rest) (cdr rest)))))]) + loop) + x1 + x2 + rest)] + [(x1) (+ x1)] + [() (+)])) "((result \"(case-lambda\\n [(x1 x2) (+ x1 x2)]\\n [(x1 x2 x3) (+ (+ x1 x2) x3)]\\n [(x1 x2 . rest)\\n ((letrec ([loop (lambda (x1 x2 rest)\\n (let ([x (+ x1 x2)])\\n (if (null? rest)\\n x\\n (loop x (car rest) (cdr rest)))))])\\n loop)\\n x1\\n x2\\n rest)]\\n [(x1) (+ x1)]\\n [() (+)])\\n\") (output . \"\"))\n") |