mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 22:59:16 +02:00
Refactoring repl.
This commit is contained in:
Alex Shinn
parent
83fb186edc
commit
053f293e5e
2 changed files with 231 additions and 182 deletions
|
|
@ -1,5 +1,5 @@
|
|||
;; repl.scm - friendlier repl with line editing and signal handling
|
||||
;; Copyright (c) 2012 Alex Shinn. All rights reserved.
|
||||
;; Copyright (c) 2012-2013 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;> A user-friendly REPL with line editing and signal handling.
|
||||
|
|
@ -165,6 +165,110 @@
|
|||
;;> @item{@scheme|{@exit}| - exit the REPL}
|
||||
;;> ]
|
||||
|
||||
(define-record-type Repl
|
||||
(make-repl
|
||||
in out escape module env meta-env make-prompt history-file history raw?)
|
||||
repl?
|
||||
(in repl-in repl-in-set!)
|
||||
(out repl-out repl-out-set!)
|
||||
(escape repl-escape repl-escape-set!)
|
||||
(module repl-module repl-module-set!)
|
||||
(env repl-env repl-env-set!)
|
||||
(meta-env repl-meta-env repl-meta-env-set!)
|
||||
(make-prompt repl-make-prompt repl-make-prompt-set!)
|
||||
(history-file repl-history-file repl-history-file-set!)
|
||||
(history repl-history repl-history-set!)
|
||||
(raw? repl-raw? repl-raw?-set!))
|
||||
|
||||
(define (repl/import-aux rp args meta continue only?)
|
||||
(let* ((mod-name (cadr args))
|
||||
(mod+imps (eval `(resolve-import ',mod-name) (repl-meta-env rp))))
|
||||
(cond
|
||||
((pair? mod+imps)
|
||||
(guard
|
||||
(exn
|
||||
(else
|
||||
(print-exception exn (current-error-port))
|
||||
(warn "error loading module:" mod-name)
|
||||
(continue rp)))
|
||||
(let ((env (if only? (make-environment) (repl-env rp)))
|
||||
(imp-env
|
||||
(module-env
|
||||
(eval `(load-module ',(car mod+imps)) (repl-meta-env rp)))))
|
||||
(%import env imp-env (cdr mod+imps) #f)
|
||||
(repl-env-set! rp env)
|
||||
(continue rp))))
|
||||
(else
|
||||
(warn "couldn't find module:" mod-name)
|
||||
(continue rp)))))
|
||||
|
||||
(define (repl/import rp args meta continue)
|
||||
(repl/import-aux rp args meta continue #f))
|
||||
|
||||
(define (repl/import-only rp args meta continue)
|
||||
(repl/import-aux rp args meta continue #t))
|
||||
|
||||
(define (repl/in rp args meta continue)
|
||||
(cond
|
||||
((null? (cdr args))
|
||||
(repl-module-set! rp #f)
|
||||
(repl-env-set! rp (interaction-environment)))
|
||||
((eval `(load-module ',(cadr args)) (repl-meta-env rp))
|
||||
=> (lambda (m)
|
||||
(repl-module-set! rp (cadr args))
|
||||
(repl-env-set! rp (module-env m))))
|
||||
(else
|
||||
(warn "couldn't find module:" (cadr args))))
|
||||
(continue rp))
|
||||
|
||||
(define (repl/meta rp args meta continue)
|
||||
(cond
|
||||
((null? (cdr args))
|
||||
(warn "usage: @meta <expr>")
|
||||
(continue rp))
|
||||
((and (symbol? (cadr args))
|
||||
(eqv? (repl-escape rp) (string-ref (symbol->string (cadr args)) 0)))
|
||||
(meta rp (cdr args) (lambda _ (continue rp))))
|
||||
(else
|
||||
(eval (cadr args) (repl-meta-env rp))
|
||||
(continue rp))))
|
||||
|
||||
(define (repl/meta-module-is rp args meta continue)
|
||||
(cond
|
||||
((null? (cdr args))
|
||||
(warn "usage: @meta <module>"))
|
||||
((eval `(load-module ',(cadr args)) (repl-meta-env rp))
|
||||
=> (lambda (m) (repl-meta-env-set! rp (module-env m))))
|
||||
(else
|
||||
(warn "couldn't find module:" (cadr args))))
|
||||
(continue rp))
|
||||
|
||||
(define (repl/help rp args meta continue)
|
||||
(let ((out (repl-out rp)))
|
||||
(cond
|
||||
((null? (cdr args))
|
||||
(display "Try @help <identifier> [<module>]\n" out))
|
||||
((null? (cddr args))
|
||||
(let* ((failed (list 'failed))
|
||||
(val (guard (exn (else (print-exception exn) failed))
|
||||
(eval (second args) (repl-env rp))))
|
||||
(mod (and (procedure? val) (containing-module val))))
|
||||
(cond
|
||||
(mod
|
||||
(write val out) (newline out) (newline out)
|
||||
(print-module-binding-docs (car mod) (second args) out))
|
||||
((not (eq? val failed))
|
||||
(describe val out)))))
|
||||
(else
|
||||
(guard (exn (else (print-exception exn (current-error-port))))
|
||||
(print-module-binding-docs (third args) (second args) out))))
|
||||
(continue rp)))
|
||||
|
||||
(define (repl/exit rp args meta continue)
|
||||
;; To exit the repl simply don't call continue.
|
||||
#f)
|
||||
|
||||
;; Utility to read all objects from a port accumulated into a list.
|
||||
(define (read/ss/all port)
|
||||
(let loop ((l '()))
|
||||
(let ((x (read/ss port)))
|
||||
|
|
@ -172,21 +276,74 @@
|
|||
(reverse l)
|
||||
(loop (cons x l))))))
|
||||
|
||||
(define (repl . o)
|
||||
(define (string->sexp-list str)
|
||||
(call-with-input-string str read/ss/all))
|
||||
|
||||
(define (repl/eval rp expr-list)
|
||||
(let ((out (repl-out rp)))
|
||||
(guard (exn (else (print-exception exn out)))
|
||||
(let ((thread
|
||||
(make-thread
|
||||
(lambda ()
|
||||
;; The inner guard in the child thread catches errors
|
||||
;; from eval.
|
||||
(guard (exn (else (print-exception exn out)))
|
||||
(for-each
|
||||
(lambda (expr)
|
||||
(call-with-values (lambda () (eval expr (repl-env rp)))
|
||||
(lambda res-list
|
||||
(cond
|
||||
((not (or (null? res-list)
|
||||
(equal? res-list (list (if #f #f)))))
|
||||
(write/ss (car res-list) out)
|
||||
(for-each
|
||||
(lambda (res)
|
||||
(write-char #\space out)
|
||||
(write/ss res out))
|
||||
(cdr res-list))
|
||||
(newline out))))))
|
||||
expr-list))))))
|
||||
;; If an interrupt occurs while the child thread is
|
||||
;; still running, terminate it, otherwise wait for it
|
||||
;; to complete.
|
||||
(with-signal-handler
|
||||
signal/interrupt
|
||||
(lambda (n)
|
||||
(display "\nInterrupt\n" out)
|
||||
(thread-terminate! thread))
|
||||
(lambda () (thread-join! (thread-start! thread))))))))
|
||||
|
||||
(define (repl/eval-string rp str)
|
||||
(repl/eval
|
||||
rp
|
||||
(guard (exn (else (print-exception exn (current-error-port))))
|
||||
;; Ugly wrapper to account for the implicit state mutation
|
||||
;; implied by the #!fold-case read syntax.
|
||||
(let ((in (repl-in rp))
|
||||
(in2 (open-input-string str)))
|
||||
(set-port-fold-case! in2 (port-fold-case? in))
|
||||
(set-port-line! in2 (port-line in))
|
||||
(let ((expr-list (read/ss/all in2)))
|
||||
(set-port-fold-case! in (port-fold-case? in2))
|
||||
expr-list)))))
|
||||
|
||||
(define (keywords->repl o)
|
||||
(let* ((in (cond ((memq 'in: o) => cadr) (else (current-input-port))))
|
||||
(out (cond ((memq 'out: o) => cadr) (else (current-output-port))))
|
||||
(escape (cond ((memq 'escape: o) => cadr) (else #\@)))
|
||||
(module (cond ((memq 'module: o) => cadr) (else #f)))
|
||||
(env (cond
|
||||
((memq 'environment: o) =>
|
||||
(lambda (x)
|
||||
(if module
|
||||
(error "The module: and environment: keyword arguments should not both be given."))
|
||||
(cadr x)))
|
||||
(module
|
||||
(module-env
|
||||
(if (module? module) module (load-module module))))
|
||||
(else (interaction-environment))))
|
||||
(env
|
||||
(cond
|
||||
((memq 'environment: o) =>
|
||||
(lambda (x)
|
||||
(if module
|
||||
(error (string-append "The module: and environment: keyword "
|
||||
"arguments should not both be given.")))
|
||||
(cadr x)))
|
||||
(module
|
||||
(module-env
|
||||
(if (module? module) module (load-module module))))
|
||||
(else (interaction-environment))))
|
||||
(make-prompt
|
||||
(cond
|
||||
((memq 'make-prompt: o) => cadr)
|
||||
|
|
@ -206,179 +363,71 @@
|
|||
(make-history)))))
|
||||
(raw? (cond ((memq 'raw?: o) => cadr)
|
||||
(else (member (get-environment-variable "TERM")
|
||||
'("emacs" "dumb"))))))
|
||||
(let lp ((module module)
|
||||
(env env)
|
||||
(meta-env (module-env (load-module '(meta)))))
|
||||
(let* ((prompt (make-prompt module))
|
||||
(line
|
||||
(cond
|
||||
(raw?
|
||||
(display prompt out)
|
||||
(flush-output out)
|
||||
(read-line/complete-sexp in))
|
||||
(else
|
||||
(edit-line in out
|
||||
'prompt: prompt
|
||||
'history: history
|
||||
'complete?: buffer-complete-sexp?
|
||||
'completion: (make-sexp-buffer-completer))))))
|
||||
'("emacs" "dumb")))))
|
||||
(meta-env (cond ((memq 'meta: o) => cadr)
|
||||
(else (module-env (load-module '(meta)))))))
|
||||
(make-repl
|
||||
in out escape module env meta-env make-prompt history-file history raw?)))
|
||||
|
||||
(define (repl/edit-line rp)
|
||||
(let ((prompt ((repl-make-prompt rp) (repl-module rp)))
|
||||
(in (repl-in rp))
|
||||
(out (repl-out rp)))
|
||||
(cond
|
||||
((repl-raw? rp)
|
||||
(display prompt out)
|
||||
(flush-output out)
|
||||
(read-line/complete-sexp in))
|
||||
(else
|
||||
(edit-line in out
|
||||
'prompt: prompt
|
||||
'history: (repl-history rp)
|
||||
'complete?: buffer-complete-sexp?
|
||||
'completion: (make-sexp-buffer-completer))))))
|
||||
|
||||
(define repl-commands
|
||||
`((import . ,repl/import)
|
||||
(import-only . ,repl/import-only)
|
||||
(in . ,repl/in)
|
||||
(meta . ,repl/meta)
|
||||
(meta-module-is . ,repl/meta-module-is)
|
||||
(? . ,repl/help)
|
||||
(h . ,repl/help)
|
||||
(help . ,repl/help)
|
||||
(exit . ,repl/exit)))
|
||||
|
||||
(define (repl . o)
|
||||
(let ((rp (keywords->repl o)))
|
||||
(let lp ((rp rp))
|
||||
(let ((line (repl/edit-line rp)))
|
||||
(cond
|
||||
((or (not line) (eof-object? line)))
|
||||
((equal? line "")
|
||||
(history-reset! history)
|
||||
(lp module env meta-env))
|
||||
(history-reset! (repl-history rp))
|
||||
(lp rp))
|
||||
(else
|
||||
(history-commit! history line)
|
||||
(history-commit! (repl-history rp) line)
|
||||
(cond
|
||||
((and (> (string-length line) 0) (eqv? escape (string-ref line 0)))
|
||||
(let meta ((env env)
|
||||
(line (substring line 1 (string-length line)))
|
||||
((and (> (string-length line) 1)
|
||||
(eqv? (repl-escape rp) (string-ref line 0)))
|
||||
;; @ escaped command
|
||||
(let meta ((rp rp)
|
||||
(args (string->sexp-list (substring line 1)))
|
||||
(continue lp))
|
||||
(define (fail msg . args)
|
||||
(apply warn msg args)
|
||||
(continue module env meta-env))
|
||||
(call-with-input-string line
|
||||
(lambda (in)
|
||||
(let ((op (read/ss in)))
|
||||
(case op
|
||||
((import import-only)
|
||||
(let* ((mod-name (read in))
|
||||
(mod+imps (eval `(resolve-import ',mod-name)
|
||||
meta-env)))
|
||||
(if (pair? mod+imps)
|
||||
(guard
|
||||
(exn
|
||||
(else
|
||||
(print-exception exn (current-error-port))
|
||||
(fail "error loading module:" mod-name)))
|
||||
(let ((env (if (eq? op 'import-only)
|
||||
(let ((env (make-environment)))
|
||||
(interaction-environment env)
|
||||
env)
|
||||
env))
|
||||
(imp-env
|
||||
(vector-ref
|
||||
(eval `(load-module ',(car mod+imps))
|
||||
meta-env)
|
||||
1)))
|
||||
(%import env imp-env (cdr mod+imps) #f)
|
||||
(continue module env meta-env)))
|
||||
(fail "couldn't find module:" mod-name))))
|
||||
((in)
|
||||
(let ((name (read/ss in)))
|
||||
(cond
|
||||
((eof-object? name)
|
||||
(continue #f (interaction-environment) meta-env))
|
||||
((eval `(load-module ',name) meta-env)
|
||||
=> (lambda (m)
|
||||
(continue name (module-env m) meta-env)))
|
||||
(else
|
||||
(fail "couldn't find module:" name)))))
|
||||
((config)
|
||||
(display "Note: @config has been renamed @meta\n" out)
|
||||
(continue module env meta-env))
|
||||
((meta)
|
||||
(let ((expr (read/ss in)))
|
||||
(cond
|
||||
((and
|
||||
(symbol? expr)
|
||||
(eqv? escape (string-ref (symbol->string expr) 0)))
|
||||
(meta meta-env
|
||||
(substring line 6 (string-length line))
|
||||
(lambda _ (continue module env meta-env))))
|
||||
(else
|
||||
(eval expr meta-env)
|
||||
(continue module env meta-env)))))
|
||||
((meta-module-is)
|
||||
(let ((name (read/ss in)))
|
||||
(cond
|
||||
((eval `(load-module ',name) meta-env)
|
||||
=> (lambda (m) (lp module env (module-env m))))
|
||||
(else
|
||||
(fail "couldn't find module:" name)))))
|
||||
((? h help)
|
||||
(let* ((x (read/ss in))
|
||||
(y (read/ss in)))
|
||||
(cond
|
||||
((eof-object? x)
|
||||
(display "Try @help <identifier> [<module>]\n" out))
|
||||
((eof-object? y)
|
||||
(let* ((failed (list 'failed))
|
||||
(val (guard (exn
|
||||
(else
|
||||
(print-exception exn)
|
||||
failed))
|
||||
(eval x env)))
|
||||
(mod (and (procedure? val)
|
||||
(containing-module val))))
|
||||
(cond
|
||||
(mod
|
||||
(write val out) (newline out) (newline out)
|
||||
(print-module-binding-docs (car mod) x out))
|
||||
((not (eq? val failed))
|
||||
(describe val out)))))
|
||||
(else
|
||||
(guard (exn
|
||||
(else
|
||||
(print-exception exn (current-error-port))))
|
||||
(print-module-binding-docs y x out))))
|
||||
(continue module env meta-env)))
|
||||
((exit))
|
||||
(else
|
||||
(fail "unknown repl command:" op))))))))
|
||||
(cond
|
||||
((null? args)
|
||||
(warn "empty repl command")
|
||||
(continue rp))
|
||||
((assq (car args) repl-commands)
|
||||
=> (lambda (x) ((cdr x) rp args meta continue)))
|
||||
(else
|
||||
(warn "unknown repl command" (car args))
|
||||
(continue rp)))))
|
||||
(else
|
||||
;; The outer guard in the parent thread catches read
|
||||
;; errors and errors in the repl logic itself.
|
||||
(guard (exn (else (print-exception exn (current-error-port))))
|
||||
(let* ((expr-list
|
||||
(call-with-input-string line
|
||||
(lambda (in2)
|
||||
;; Ugly wrapper to account for the
|
||||
;; implicit state mutation implied by
|
||||
;; the #!fold-case read syntax.
|
||||
(set-port-fold-case! in2 (port-fold-case? in))
|
||||
(let ((expr-list (read/ss/all in2)))
|
||||
(set-port-fold-case! in (port-fold-case? in2))
|
||||
expr-list))))
|
||||
(thread
|
||||
(make-thread
|
||||
(lambda ()
|
||||
;; The inner guard in the child thread
|
||||
;; catches errors from eval.
|
||||
(guard
|
||||
(exn
|
||||
(else
|
||||
(print-exception exn (current-output-port))))
|
||||
(for-each
|
||||
(lambda (expr)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(eval (list 'begin expr) env))
|
||||
(lambda res-list
|
||||
(cond
|
||||
((not (or (null? res-list)
|
||||
(equal? res-list
|
||||
(list (if #f #f)))))
|
||||
(write/ss (car res-list) out)
|
||||
(for-each
|
||||
(lambda (res)
|
||||
(write-char #\space out)
|
||||
(write/ss res out))
|
||||
(cdr res-list))
|
||||
(newline out))))))
|
||||
expr-list))))))
|
||||
;; If an interrupt occurs while the child thread is
|
||||
;; still running, terminate it, otherwise wait for it
|
||||
;; to complete.
|
||||
(with-signal-handler
|
||||
signal/interrupt
|
||||
(lambda (n)
|
||||
(display "\nInterrupt\n" (current-error-port))
|
||||
(thread-terminate! thread))
|
||||
(lambda () (thread-join! (thread-start! thread))))))
|
||||
;; Loop whether there were errors or interrupts or not.
|
||||
(lp module env meta-env)))))))
|
||||
(if history-file
|
||||
(call-with-output-file history-file
|
||||
(lambda (out) (write (history->list history) out))))))
|
||||
;; Normal expression to eval.
|
||||
(repl/eval-string rp line)
|
||||
(lp rp)))))))
|
||||
;; Update the history file on completion.
|
||||
(if (repl-history-file rp)
|
||||
(call-with-output-file (repl-history-file rp)
|
||||
(lambda (out) (write (history->list (repl-history rp)) out))))))
|
||||
|
|
|
|||
|
|
@ -5,5 +5,5 @@
|
|||
(chibi ast) (chibi modules) (chibi doc)
|
||||
(chibi string) (chibi io)
|
||||
(chibi process) (chibi term edit-line)
|
||||
(srfi 1) (srfi 18) (srfi 38) (srfi 95) (srfi 98))
|
||||
(srfi 1) (srfi 9) (srfi 18) (srfi 38) (srfi 95) (srfi 98))
|
||||
(include "repl.scm"))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue