Documentation updates, making (chibi repl) history persistent.

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 [<module>]}| - switch to @var{<module>}, or the @scheme{interaction-environment} if @var{<module>} is not specified}
+;;> @item{@scheme|{@config <expr>}| - evaluate @var{<expr>} in the @scheme{(config)} module}
+;;> @item{@scheme|{@config-module-is <module>}| - switch the config module to @var{<module>}}
+;;> @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-env
-                                  module
+                   (if (module? module)
-                                  (eval `(load-module ',module) *config-env*)))
+                       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)
+                (display prompt out)
-                (flush-output)
+                (flush-output out)
-                (read-line))
+                (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)
+                         ((and
-                               (eqv? #\@ (string-ref (symbol->string expr) 0)))
+                           (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))))))

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

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)))))

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

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"))

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 '()))

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-begin test-end ;; test-syntax-error ;; test-info
-   test-vars test-run ;;test-exit
+   ;; 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)

lib/chibi/test.scm

@@ -1,23 +1,12 @@
-;;;; test.scm -- testing framework
+;; Copyright (c) 2010-2011 Alex Shinn. All rights reserved.
-;;
-;; Easy to use test suite adapted from the Chicken "test" module.
-;;
-;; Copyright (c) 2010 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
+       (guard
-        exn
+        (exn
-        (begin
+         (else
-          (warning "error in group outside of tests")
+           (warning "error in group outside of tests")
-          (print-exception e (current-error-port))
+           (print-exception e (current-error-port))
-          (test-group-inc! (current-test-group) 'count)
+           (test-group-inc! (current-test-group) 'count)
-          (test-group-inc! (current-test-group) 'ERROR))
+           (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
+           (guard
-            exn
+            (exn
-            (begin
+             (else
-              (warning "bad expect value")
+               (warning "bad expect value")
-              (print-exception exn (current-error-port))
+               (print-exception exn (current-error-port))
-              #f)
+               #f))
             (expect))))
-      (handle-exceptions
+      (guard
-       exn
+       (exn
-       (begin
+        (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
+          (guard
-           exn
+           (exn
-           (begin
+            (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)))