From 357684a730ede97a1b540465c8e24bba42c88e78 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 23 May 2011 02:09:24 -0700 Subject: [PATCH] Documentation updates, making (chibi repl) history persistent. --- lib/chibi/repl.scm | 90 +++++++++++++++++++++++++------ lib/chibi/scribble.scm | 7 +++ lib/chibi/stty.scm | 25 +++++++++ lib/chibi/system.stub | 23 ++++++++ lib/chibi/term/edit-line.module | 2 +- lib/chibi/term/edit-line.scm | 3 ++ lib/chibi/test.module | 4 +- lib/chibi/test.scm | 93 ++++++++++++++++++++------------- 8 files changed, 193 insertions(+), 54 deletions(-) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index 36e1adaf..98447b3b 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -1,8 +1,17 @@ -;;;; repl.scm - friendlier repl with line editing and signal handling -;; +;; repl.scm - friendlier repl with line editing and signal handling ;; Copyright (c) 2011 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt +;;> A user-friendly REPL with line editing and signal handling. +;;> The default REPL provided by chibi-scheme is very minimal, +;;> meant primarily to be small and work on any platform. This +;;> module provides an advanced REPL that handles vt100 line +;;> editing and signal handling, so that C-c will interrupt a +;;> computation and bring you back to the REPL prompt. To use +;;> this repl, run +;;> @command{chibi-scheme -mchibi.repl -e'(repl)'} +;;> from the command line or within Emacs. + (define (with-signal-handler sig handler thunk) (let ((old-handler #f)) (dynamic-wind @@ -29,14 +38,60 @@ (define module? vector?) (define (module-env mod) (vector-ref mod 1)) +;;> Runs an interactive REPL. Repeatedly displays a prompt, +;;> then Reads an expression, Evaluates the expression, Prints +;;> the result then Loops. Terminates when the end of input is +;;> reached or the @scheme|{@exit}| command is given. +;;> +;;> Basic Emacs-style line editing with persistent history +;;> completion is provided. C-c can be used to interrupt the +;;> current computation and drop back to the prompt. The +;;> following keyword arguments customize the REPL: +;;> +;;> @itemlist[ +;;> @item{@scheme{in:} - the input port (default @scheme{(current-input-port)})} +;;> @item{@scheme{out:} - the output port (default @scheme{(current-output-port)})} +;;> @item{@scheme{module:} - the initial module (default @scheme{(interaction-environment)})} +;;> @item{@scheme{escape:} - the command escape character (default @scheme|{#\@}|)} +;;> @item{@scheme{history:} - the initial command history} +;;> @item{@scheme{history-file:} - the file to save history to (default ~/.chibi-repl-history)} +;;> ] +;;> +;;> REPL commands in the style of @hyperlink["http://s48.org/"]{Scheme48} +;;> are available to control out-of-band properties. By default a command +;;> is written as an identifier beginning with an "@" character (which +;;> would not be a portable identifier), but this can be customized with +;;> the @scheme{escape:} keyword. The following commands are available: +;;> +;;> @itemlist[ +;;> @item{@scheme|{@in []}| - switch to @var{}, or the @scheme{interaction-environment} if @var{} is not specified} +;;> @item{@scheme|{@config }| - evaluate @var{} in the @scheme{(config)} module} +;;> @item{@scheme|{@config-module-is }| - switch the config module to @var{}} +;;> @item{@scheme|{@exit}| - exit the REPL} +;;> ] + (define (repl . o) - (let* ((module (cond ((memq 'module: o) => cadr) (else #f))) + (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 (if module - (module-env (if (module? module) - module - (eval `(load-module ',module) *config-env*))) + (module-env + (if (module? module) + module + (eval `(load-module ',module) *config-env*))) (interaction-environment))) - (history (cond ((memq 'history: o) => cadr) (else (make-history)))) + (history-file + (cond ((memq 'history-file: o) => cadr) + (else (string-append (get-environment-variable "HOME") + "/.chibi-repl-history")))) + (history + (cond ((memq 'history: o) => cadr) + (else + (or (guard (exn (else #f)) + (list->history + (call-with-input-file history-file read))) + (make-history))))) (raw? (cond ((memq 'raw?: o) => cadr) (else (member (get-environment-variable "TERM") '("emacs" "dumb")))))) @@ -46,11 +101,11 @@ (line (cond (raw? - (display prompt) - (flush-output) - (read-line)) + (display prompt out) + (flush-output out) + (read-line in)) (else - (edit-line + (edit-line in out 'prompt: prompt 'history: history 'complete?: buffer-complete-sexp?))))) @@ -60,7 +115,7 @@ (else (history-commit! history line) (cond - ((and (> (string-length line) 0) (eqv? #\@ (string-ref line 0))) + ((and (> (string-length line) 0) (eqv? escape (string-ref line 0))) (let meta ((env env) (line (substring line 1 (string-length line))) (continue lp)) @@ -84,8 +139,9 @@ ((config) (let ((expr (read/ss in))) (cond - ((and (symbol? expr) - (eqv? #\@ (string-ref (symbol->string expr) 0))) + ((and + (symbol? expr) + (eqv? escape (string-ref (symbol->string expr) 0))) (meta config-env (substring line 6 (string-length line)) (lambda _ (continue module env config-env)))) @@ -99,6 +155,7 @@ => (lambda (m) (lp module env (module-env m)))) (else (fail "couldn't find module:" name))))) + ((exit)) (else (fail "unknown repl command:" op)))))))) (else @@ -123,4 +180,7 @@ (display "Interrupt\n" (current-error-port)) (thread-terminate! thread)) (lambda () (thread-join! (thread-start! thread)))))) - (lp module env config-env))))))))) + (lp module env config-env))))))) + (if history-file + (call-with-output-file history-file + (lambda (out) (write (history->list history) out)))))) diff --git a/lib/chibi/scribble.scm b/lib/chibi/scribble.scm index cc3ebdb1..fba8bf0c 100644 --- a/lib/chibi/scribble.scm +++ b/lib/chibi/scribble.scm @@ -1,3 +1,10 @@ +;; scribble.scm - scribble parsing +;; Copyright (c) 2011 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> A library used for parsing "scribble" format, introduced +;;> by @hyperlink["http://www.racket-lang.org/"]{Racket} and +;;> the format used to write this manual. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; general character utils diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm index a1575d94..544ace1d 100644 --- a/lib/chibi/stty.scm +++ b/lib/chibi/stty.scm @@ -1,3 +1,7 @@ +;; Copyright (c) 2011 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> A high-level interface to stty and ioctl. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; symbolic representation of attributes @@ -160,6 +164,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; high-level interface +;;> @subsubsubsection{@scheme{(stty [port] args ...)}} + +;;> Set the terminal attributes for @var{port} (default +;;> @scheme{(current-output-port)}) to @var{attrs}. +;;> Attributes are specified symbolically using the +;;> names from the @rawcode{stty(1)} command. In addition, +;;> (not args ...) may be used to negate the listed symbols. + (define (stty . args) (let* ((port (if (and (pair? args) (port? (car args))) (car args) @@ -213,6 +225,10 @@ (else (return iflag oflag cflag lflag)))))) +;;> Run @var{thunk} with the @scheme{stty} @var{setting}s in effect +;;> during its dynamic extent, resetting the original settings +;;> when it returns. + (define (with-stty setting thunk . o) (let* ((port (if (pair? o) (car o) (current-input-port))) (orig-attrs (get-terminal-attributes port))) @@ -221,13 +237,22 @@ thunk (lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))) +;;> Run @var{thunk} with the "raw" (no canonical or echo) options +;;> needed for a terminal application. + (define (with-raw-io port thunk) (with-stty '(not icanon echo) thunk port)) +;;> Returns the current terminal width in characters of @var{x}, +;;> which must be a port or a file descriptor. + (define (get-terminal-width x) (let ((ws (ioctl x TIOCGWINSZ))) (and ws (winsize-col ws)))) +;;> Returns the current terminal dimensions, as a list of character width +;;> and height, of @var{x}, which must be a port or a file descriptor. + (define (get-terminal-dimensions x) (let ((ws (ioctl x TIOCGWINSZ))) (and ws (list (winsize-col ws) (winsize-row ws))))) diff --git a/lib/chibi/system.stub b/lib/chibi/system.stub index 00c372e1..8ac88150 100644 --- a/lib/chibi/system.stub +++ b/lib/chibi/system.stub @@ -3,6 +3,12 @@ (c-system-include "pwd.h") (c-system-include "sys/types.h") +;;> @subsubsubsection{@scheme{(user-information name-or-id)}} + +;;> Returns the password entry for the given user. @var{name-or-id} +;;> should be a string indicating the user name, or an integer +;;> for the user id. + (define-c-struct passwd predicate: user? (string pw_name user-name) @@ -13,6 +19,10 @@ (string pw_dir user-home) (string pw_shell user-shell)) +;;> Accessors for the password entry structure returned by +;;> @scheme{user-information}. +;;/ + (define-c uid_t (current-user-id "getuid") ()) (define-c gid_t (current-group-id "getgid") ()) (define-c uid_t (current-effective-user-id "geteuid") ()) @@ -23,9 +33,22 @@ (define-c errno (set-current-group-id! "setgid") (gid_t)) (define-c errno (set-current-effective-group-id! "setegid") (gid_t)) +;;> Accessors for the current user credentials. +;;/ + +;;> Returns the session id of the specified process, +;;> defaulting to the current process. + (define-c pid_t (current-session-id "getsid") ((default 0 pid_t))) + +;;> Creates a new session. + (define-c pid_t (create-session "setsid") ()) +;;> Set @var{string} to be the new root directory, so that +;;> paths beginning with "/" are resolved relative to the +;;> new root. + (define-c errno (set-root-directory! "chroot") (string)) (define-c errno getpwuid_r diff --git a/lib/chibi/term/edit-line.module b/lib/chibi/term/edit-line.module index f9c2e6f7..35c1b2c9 100644 --- a/lib/chibi/term/edit-line.module +++ b/lib/chibi/term/edit-line.module @@ -1,6 +1,6 @@ (module (chibi term edit-line) (export edit-line edit-line-repl make-history history-insert! history-commit! - buffer->string) + history->list list->history buffer->string) (import-immutable (scheme) (chibi stty) (srfi 9)) (include "edit-line.scm")) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm index 15e5b169..9808a480 100644 --- a/lib/chibi/term/edit-line.scm +++ b/lib/chibi/term/edit-line.scm @@ -42,6 +42,9 @@ (let ((past (history-past h)) (future (history-future h))) (if (pair? past) (cons (car past) (append future (cdr past))) future))) +(define (list->history ls) + (%make-history (max maximum-history-size (length ls)) ls '())) + (define (history-flatten! h) (history-past-set! h (history->list h)) (history-future-set! h '())) diff --git a/lib/chibi/test.module b/lib/chibi/test.module index 8c084653..73fce2a7 100644 --- a/lib/chibi/test.module +++ b/lib/chibi/test.module @@ -3,8 +3,8 @@ (export test test-error test-assert test-not test-values test-group current-test-group - test-begin test-end test-syntax-error test-info - test-vars test-run ;;test-exit + test-begin test-end ;; test-syntax-error ;; test-info + ;; test-vars test-run ;; test-exit current-test-verbosity current-test-epsilon current-test-comparator current-test-applier current-test-handler current-test-skipper current-test-group-reporter test-failure-count) diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index 39939e8c..e5f07d7b 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -1,23 +1,12 @@ -;;;; test.scm -- testing framework -;; -;; Easy to use test suite adapted from the Chicken "test" module. -;; -;; Copyright (c) 2010 Alex Shinn. All rights reserved. +;; Copyright (c) 2010-2011 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt +;;> Simple testing framework adapted from the Chicken @scheme{test} +;;> module. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; exception utilities -;; from SRFI-12, pending stabilization of an exception library for WG1 -(define-syntax handle-exceptions - (syntax-rules () - ((handle-exceptions exn handler body ...) - (call-with-current-continuation - (lambda (return) - (with-exception-handler - (lambda (exn) (return handler)) - (lambda () body ...))))))) - (define (warning msg . args) (display msg (current-error-port)) (for-each (lambda (x) @@ -53,6 +42,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; test interface +;;> @subsubsubsection{@scheme{(test [name] expect expr)}} + +;;> Evaluate @var{expr} and check that it is @scheme{equal?} +;;> to @var{expect}. @var{name} is used in reporting, and +;;> defaults to a printed summary of @var{expr}. + (define-syntax test (syntax-rules () ((test expect expr) @@ -70,6 +65,10 @@ (test-syntax-error 'test "2 or 3 arguments required" (test a ...))))) +;;> @subsubsubsection{@scheme{(test-assert [name] expr)}} + +;;> Like @scheme{test} but evaluates @var{expr} and checks that it's true. + (define-syntax test-assert (syntax-rules () ((_ expr) @@ -80,11 +79,20 @@ (test-syntax-error 'test-assert "1 or 2 arguments required" (test a ...))))) +;;> @subsubsubsection{@scheme{(test-not [name] expr)}} + +;;> Like @scheme{test} but evaluates @var{expr} and checks that it's false. + (define-syntax test-not (syntax-rules () ((_ expr) (test-assert (not expr))) ((_ name expr) (test-assert name (not expr))))) +;;> @subsubsubsection{@scheme{(test-values [name] expect expr)}} + +;;> Like @scheme{test} but @var{expect} and @var{expr} can both +;;> return multiple values. + (define-syntax test-values (syntax-rules () ((_ expect expr) @@ -93,6 +101,11 @@ (test name (call-with-values (lambda () expect) (lambda results results)) (call-with-values (lambda () expr) (lambda results results)))))) +;;> @subsubsubsection{@scheme{(test-error [name] expr)}} + +;;> Like @scheme{test} but evaluates @var{expr} and checks that it +;;> raises an error. + (define-syntax test-error (syntax-rules () ((_ expr) @@ -106,6 +119,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; group interface +;;> Wraps @var{body} as a single test group, which can be filtered +;;> and summarized separately. + (define-syntax test-group (syntax-rules () ((_ name-expr body ...) @@ -114,13 +130,13 @@ (if (not (string? name)) (error "a name is required, got " 'name-expr name)) (test-begin name) - (handle-exceptions - exn - (begin - (warning "error in group outside of tests") - (print-exception e (current-error-port)) - (test-group-inc! (current-test-group) 'count) - (test-group-inc! (current-test-group) 'ERROR)) + (guard + (exn + (else + (warning "error in group outside of tests") + (print-exception e (current-error-port)) + (test-group-inc! (current-test-group) 'count) + (test-group-inc! (current-test-group) 'ERROR))) body ...) (test-end name) (current-test-group old-group))))) @@ -320,21 +336,21 @@ (display (make-string indent #\space))) (test-print-name info indent) (let ((expect-val - (handle-exceptions - exn - (begin - (warning "bad expect value") - (print-exception exn (current-error-port)) - #f) + (guard + (exn + (else + (warning "bad expect value") + (print-exception exn (current-error-port)) + #f)) (expect)))) - (handle-exceptions - exn - (begin + (guard + (exn + (else ((current-test-handler) (if (assq-ref info 'expect-error) 'PASS 'ERROR) expect expr - (append `((exception . ,exn)) info))) + (append `((exception . ,exn)) info)))) (let ((res (expr))) (let ((status (if (and (not (assq-ref info 'expect-error)) @@ -528,6 +544,8 @@ (display (make-string (max 0 (- (current-column-width) len)) #\-)) (newline))) +;;> Begin testing a new group until the closing @scheme{(test-end)}. + (define (test-begin . o) (let* ((name (if (pair? o) (car o) "")) (group (make-test-group name)) @@ -557,6 +575,9 @@ (not (every (lambda (f) (f group)) (current-test-group-filters))))) (current-test-group group))) +;;> Ends testing group introduced with @scheme{(test-begin)}, and +;;> summarizes the results. + (define (test-end . o) (cond ((current-test-group) @@ -625,14 +646,14 @@ (cond ((get-environment-variable name) => (lambda (s) - (handle-exceptions - exn - (begin + (guard + (exn + (else (warning (string-append "invalid filter '" s "' from environment variable: " name)) (print-exception exn (current-error-port)) - '()) + '())) (let ((f (proc s))) (list (if (and (pair? o) (car o)) (lambda (x) (not (f x)))