diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index 7c159e32..09612775 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -1403,7 +1403,7 @@ namespace. \item{\hyperlink["lib/chibi/shell.html"]{(chibi shell) - Process combinators with high-level pipeline syntax in the spirit of SCSH.}} -\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formattinga.}} +\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formatting.}} \item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}} diff --git a/lib/chibi/csv-test.sld b/lib/chibi/csv-test.sld new file mode 100644 index 00000000..3842667d --- /dev/null +++ b/lib/chibi/csv-test.sld @@ -0,0 +1,72 @@ + +(define-library (chibi csv-test) + (import (scheme base) + (srfi 227) + (chibi csv) + (chibi test)) + (export run-tests) + (begin + (define string->csv + (opt-lambda (str (reader (csv-read->list))) + (reader (open-input-string str)))) + (define (run-tests) + (test-begin "(chibi csv)") + (test-assert (eof-object? (string->csv ""))) + (test '("1997" "Ford" "E350") + (string->csv "1997,Ford,E350")) + (test '("1997" "Ford" "E350") + (string->csv "\n1997,Ford,E350")) + (test '(" ") + (string->csv " \n1997,Ford,E350")) + (test '("" "") + (string->csv ",\n1997,Ford,E350")) + (test '("1997" "Ford" "E350") + (string->csv "\"1997\",\"Ford\",\"E350\"")) + (test '("1997" "Ford" "E350" "Super, luxurious truck") + (string->csv "1997,Ford,E350,\"Super, luxurious truck\"")) + (test '("1997" "Ford" "E350" "Super, \"luxurious\" truck") + (string->csv "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\"")) + (test '("1997" "Ford" "E350" "Go get one now\nthey are going fast") + (string->csv "1997,Ford,E350,\"Go get one now +they are going fast\"")) + (test '("1997" "Ford" "E350") + (string->csv + "# this is a comment\n1997,Ford,E350" + (csv-read->list + (csv-parser (csv-grammar '((comment-chars #\#))))))) + (test '("1997" "Fo\"rd" "E3\"50") + (string->csv "1997\tFo\"rd\tE3\"50" + (csv-read->list (csv-parser default-tsv-grammar)))) + (test '#("1997" "Ford" "E350") + (string->csv "1997,Ford,E350" (csv-read->vector))) + (test '#("1997" "Ford" "E350") + (string->csv "1997,Ford,E350" (csv-read->fixed-vector 3))) + (test-error + (string->csv "1997,Ford,E350" (csv-read->fixed-vector 2))) + (let ((city-csv "Los Angeles,34°03′N,118°15′W +New York City,40°42′46″N,74°00′21″W +Paris,48°51′24″N,2°21′03″E")) + (test '(*TOP* + (row (col-0 "Los Angeles") + (col-1 "34°03′N") + (col-2 "118°15′W")) + (row (col-0 "New York City") + (col-1 "40°42′46″N") + (col-2 "74°00′21″W")) + (row (col-0 "Paris") + (col-1 "48°51′24″N") + (col-2 "2°21′03″E"))) + ((csv->sxml) (open-input-string city-csv))) + (test '(*TOP* + (city (name "Los Angeles") + (latitude "34°03′N") + (longitude "118°15′W")) + (city (name "New York City") + (latitude "40°42′46″N") + (longitude "74°00′21″W")) + (city (name "Paris") + (latitude "48°51′24″N") + (longitude "2°21′03″E"))) + ((csv->sxml 'city '(name latitude longitude)) + (open-input-string city-csv)))) + (test-end)))) diff --git a/lib/chibi/csv.scm b/lib/chibi/csv.scm new file mode 100644 index 00000000..b51e54e9 --- /dev/null +++ b/lib/chibi/csv.scm @@ -0,0 +1,362 @@ + +;;> \section{CSV Grammars} + +;;> CSV is a simple and compact format for tabular data, which has +;;> made it popular for a variety of tasks since the early days of +;;> computing. Unfortunately, there are many incompatible dialects +;;> requiring a grammar to specify all of the different options. + +(define-record-type Csv-Grammar + (make-csv-grammar separator-chars quote-char escape-char record-separator comment-chars) + csv-grammar? + (separator-chars csv-grammar-separator-chars csv-grammar-separator-chars-set!) + (quote-char csv-grammar-quote-char csv-grammar-quote-char-set!) + (escape-char csv-grammar-escape-char csv-grammar-escape-char-set!) + (record-separator csv-grammar-record-separator csv-grammar-record-separator-set!) + (comment-chars csv-grammar-comment-chars csv-grammar-comment-chars-set!)) + +;; TODO: Consider some minimal low-level parsing options. In general +;; this is intended to be performed by the parser, but if we can skip +;; intermediate string generation (e.g. parsing numbers directly) it +;; can save a considerable amount of garbage when parsing large files. + +;;> Creates a new CSV grammar from the given spec, an alist of symbols +;;> to values. The following options are supported: +;;> +;;> \itemlist[ +;;> \item{\scheme{'separator-chars} - A non-empty list of characters used to delimit fields, by default \scheme{'(#\\,)} (comma-separated).} +;;> \item{\scheme{'quote-char} - A single character used to quote fields containing special characters, or \scheme{#f} to disable quoting, by default \scheme{#\\"} (a double-quote).} +;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#\\"} (a double-quote). If this is the same character as the \scheme{quote-char}, then the quote char can be doubled to escape, but no other characters can be escaped.} +;;> \item{\scheme{'record-separator} - A single character used to delimit the record (row), or one of the symbols \scheme{'cr}, \scheme{'crlf}, \scheme{'lf} or \scheme{'lax}. These correspond to sequences of carriage return and line feed, or in the case of \scheme{'lax} any of the other three sequences. Defaults to \scheme{'lax}.} +;;> \item{\scheme{'comment-chars} - A list of characters which if found at the start of a record indicate it is a comment, discarding all characters through to the next record-separator. Defaults to the empty list (no comments).} +;;> ] +;;> +;;> Example Gecos grammar: +;;> +;;> \example{ +;;> (csv-grammar +;;> '((separator-chars #\\:) +;;> (quote-char . #f) +;;> (escape-char . #f))) +;;> } +(define (csv-grammar spec) + (let ((grammar (make-csv-grammar '(#\,) #\" #\" 'lax '()))) + (for-each + (lambda (x) + (case (car x) + ((separator-chars delimiter) + (csv-grammar-separator-chars-set! grammar (cdr x))) + ((quote-char) + (csv-grammar-quote-char-set! grammar (cdr x))) + ((escape-char) + (csv-grammar-escape-char-set! grammar (cdr x))) + ((record-separator newline-type) + (let ((rec-sep + (case (cdr x) + ((crlf lax) (cdr x)) + ((cr) #\return) + ((lf) #\newline) + (else + (if (char? (cdr x)) + (cdr x) + (error "invalid record-separator, expected a char or one of 'lax or 'crlf" (cdr x))))))) + (csv-grammar-escape-char-set! grammar (cdr x)))) + ((comment-chars) + (csv-grammar-comment-chars-set! grammar (cdr x))) + (else + (error "unknown csv-grammar spec" x)))) + spec) + grammar)) + +;;> The default CSV grammar for convenience, with all of the defaults +;;> from \scheme{csv-grammar}, i.e. comma-delimited with \scheme{#\"} +;;> for quoting, doubled to escape. +(define default-csv-grammar + (csv-grammar '())) + +;;> The default TSV grammar for convenience, splitting fields only on +;;> tabs, with no quoting or escaping. +(define default-tsv-grammar + (csv-grammar '((separator-chars #\tab) (quote-char . #f) (escape-char . #f)))) + +;;> \section{CSV Parsers} + +;;> Parsers are low-level utilities to perform operations on records a +;;> field at a time. You generally want to work with readers, which +;;> build on this to build records into familiar data structures. + +;;> Parsers follow the rules of a grammar to parse a single CSV +;;> record, possible comprised of multiple fields. A parser is a +;;> procedure of three arguments which performs a fold operation over +;;> the fields of the record. The parser signature is: +;;> \scheme{(parser kons knil in)}, where \scheme{kons} itself is +;;> a procedure of three arguments: \scheme{(proc acc index field)}. +;;> \scheme{proc} is called on each field of the record, in order, +;;> along with its zero-based \scheme{index} and the accumulated +;;> result of the last call, starting with \scheme{knil}. + +;;> Returns a new CSV parser for the given \var{grammar}. The parser +;;> by itself can be used to parse a record at a time. +;;> +;;> \example{ +;;> (let ((parse (csv-parser))) +;;> (parse (lambda (vec i field) (vector-set! vec i (string->number field)) vec) +;;> (make-vector 3) +;;> (open-input-string "1,2,3"))) +;;> } +(define csv-parser + (opt-lambda ((grammar default-csv-grammar)) + (lambda (kons knil in) + (when (pair? (csv-grammar-comment-chars grammar)) + (let lp () + (when (memv (peek-char in) (csv-grammar-comment-chars grammar)) + (csv-skip-line in grammar) + (lp)))) + (let lp ((acc knil) + (index 0) + (out (open-output-string))) + (define (finish-row) + (let ((field (get-output-string out))) + (if (and (zero? index) (equal? field "")) + ;; empty row, read again + (lp acc index out) + (kons acc index field)))) + (let ((ch (read-char in))) + (cond + ((eof-object? ch) + (let ((field (get-output-string out))) + (if (and (zero? index) (equal? field "")) + ;; no data + ch + (kons acc index field)))) + ((memv ch (csv-grammar-separator-chars grammar)) + (lp (kons acc index (get-output-string out)) + (+ index 1) + (open-output-string))) + ((eqv? ch (csv-grammar-quote-char grammar)) + ;; TODO: Consider a strict mode to enforce no text + ;; before/after the quoted text. + (csv-read-quoted in out grammar) + (lp acc index out)) + ((eqv? ch (csv-grammar-record-separator grammar)) + (finish-row)) + ((and (eqv? ch #\return) + (memq (csv-grammar-record-separator grammar) '(crlf lax))) + (cond + ((eqv? (peek-char in) #\newline) + (read-char in) + (finish-row)) + ((eq? (csv-grammar-record-separator grammar) 'lax) + (finish-row)) + (else + (write-char ch out) + (lp acc (+ index 1) out)))) + ((and (eqv? ch #\newline) + (eq? (csv-grammar-record-separator grammar) 'lax)) + (finish-row)) + (else + (write-char ch out) + (lp acc index out)))))))) + +(define (csv-skip-line in grammar) + (let lp () + (let ((ch (read-char in))) + (cond + ((eof-object? ch)) + ((eqv? ch (csv-grammar-record-separator grammar))) + ((and (eqv? ch #\newline) + (eq? (csv-grammar-record-separator grammar) 'lax))) + ((and (eqv? ch #\return) + (memq (csv-grammar-record-separator grammar) '(crlf lax))) + (cond + ((eqv? (peek-char in) #\newline) (read-char in)) + ((eq? (csv-grammar-record-separator grammar) 'lax)) + (else (lp)))) + (else (lp)))))) + +(define (csv-read-quoted in out grammar) + (let lp () + (let ((ch (read-char in))) + (cond + ((eof-object? ch) + (error "unterminated csv quote" (get-output-string out))) + ((eqv? ch (csv-grammar-quote-char grammar)) + (when (and (eqv? ch (csv-grammar-escape-char grammar)) + (eqv? ch (peek-char in))) + (write-char (read-char in) out) + (lp))) + ((eqv? ch (csv-grammar-escape-char grammar)) + (write-char (read-char in) out) + (lp)) + (else + ;; TODO: Consider an option to disable newlines in quotes. + (write-char ch out) + (lp)))))) + +;;> \section{CSV Readers} + +;;> A CSV reader reads a single record, returning some representation +;;> of it. You can either loop manually with these or pass them to +;;> one of the high-level utilities to operate on a whole CSV file at +;;> a time. + +;;> The simplest reader, simply returns the field string values in +;;> order as a list. +;;> +;;> \example{ +;;> ((csv-read->list) (open-input-string "foo,bar,baz")) +;;> } +(define csv-read->list + (opt-lambda ((parser (csv-parser))) + (opt-lambda ((in (current-input-port))) + (let ((res (parser (lambda (ls i field) (cons field ls)) '() in))) + (if (pair? res) + (reverse res) + res))))) + +;;> The equivalent of \scheme{csv-read->list} but returns a vector. +;;> +;;> \example{ +;;> ((csv-read->vector) (open-input-string "foo,bar,baz")) +;;> } +(define csv-read->vector + (opt-lambda ((parser (csv-parser))) + (let ((reader (csv-read->list parser))) + (opt-lambda ((in (current-input-port))) + (let ((res (reader in))) + (if (pair? res) + (list->vector res) + res)))))) + +;;> The same as \scheme{csv-read->vector} but requires the vector to +;;> be of a fixed size, and may be more efficient. +;;> +;;> \example{ +;;> ((csv-read->fixed-vector 3) (open-input-string "foo,bar,baz")) +;;> } +(define csv-read->fixed-vector + (opt-lambda (size (parser (csv-parser))) + (opt-lambda ((in (current-input-port))) + (let ((res (make-vector size))) + (let ((len (parser (lambda (prev-i i field) (vector-set! res i field) i) + 0 + in))) + (if (zero? len) + eof-object + res)))))) + +;;> Returns an SXML representation of the record, as a row with +;;> multiple named columns. +;;> +;;> \example{ +;;> ((csv-read->sxml 'city '(name latitude longitude)) +;;> (open-input-string "Tokyo,35°41′23″N,139°41′32″E")) +;;> } +(define csv-read->sxml + (opt-lambda ((row-name 'row) + (column-names + (lambda (i) + (string->symbol (string-append "col-" (number->string i))))) + (parser (csv-parser))) + (define (get-column-name i) + (if (procedure? column-names) + (column-names i) + (list-ref column-names i))) + (opt-lambda ((in (current-input-port))) + (let ((res (parser (lambda (ls i field) + `((,(get-column-name i) ,field) ,@ls)) + (list row-name) + in))) + (if (pair? res) + (reverse res) + res))))) + +;;> \section{CSV Utilities} + +;;> A folding operation on records. \var{proc} is called successively +;;> on each row and the accumulated result. +;;> +;;> \example{ +;;> (csv-fold +;;> (lambda (row acc) (cons (cadr (assq 'name (cdr row))) acc)) +;;> '() +;;> (csv-read->sxml 'city '(name latitude longitude)) +;;> (open-input-string +;;> "Tokyo,35°41′23″N,139°41′32″E +;;> Paris,48°51′24″N,2°21′03″E")) +;;> } +(define csv-fold + (opt-lambda (proc + knil + (reader (csv-read->list)) + (in (current-input-port))) + (let lp ((acc knil)) + (let ((row (reader in))) + (cond + ((eof-object? row) acc) + (else (lp (proc row acc)))))))) + +;;> An iterator which simply calls \var{proc} on each record in the +;;> input in order. +;;> +;;> \example{ +;;> (let ((count 0)) +;;> (csv-for-each +;;> (lambda (row) (if (string->number (car row)) (set! count (+ 1 count)))) +;;> (csv-read->list) +;;> (open-input-string +;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux")) +;;> count) +;;> } +(define csv-for-each + (opt-lambda (proc + (reader (csv-read->list)) + (in (current-input-port))) + (csv-fold (lambda (row acc) (proc row)) #f reader in))) + +;;> Returns a list containing the result of calling \var{proc} on each +;;> element in the input. +;;> +;;> \example{ +;;> (csv-map +;;> (lambda (row) (string->symbol (cadr row))) +;;> (csv-read->list) +;;> (open-input-string +;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux")) +;;> } +(define csv-map + (opt-lambda (proc + (reader (csv-read->list)) + (in (current-input-port))) + (reverse (csv-fold (lambda (row acc) (cons (proc row) acc)) '() reader in)))) + +;;> Returns a list of all of the read records in the input. +;;> +;;> \example{ +;;> (csv->list +;;> (csv-read->list) +;;> (open-input-string +;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux")) +;;> } +(define csv->list + (opt-lambda ((reader (csv-read->list)) + (in (current-input-port))) + (csv-map (lambda (row) row) reader in))) + +;;> Returns an SXML representation of the CSV. +;;> +;;> \example{ +;;> ((csv->sxml 'city '(name latitude longitude)) +;;> (open-input-string +;;> "Tokyo,35°41′23″N,139°41′32″E +;;> Paris,48°51′24″N,2°21′03″E")) +;;> } +(define csv->sxml + (opt-lambda ((row-name 'row) + (column-names + (lambda (i) + (string->symbol (string-append "col-" (number->string i))))) + (parser (csv-parser))) + (opt-lambda ((in (current-input-port))) + (cons '*TOP* + (csv->list (csv-read->sxml row-name column-names parser) in))))) diff --git a/lib/chibi/csv.sld b/lib/chibi/csv.sld new file mode 100644 index 00000000..f4df593d --- /dev/null +++ b/lib/chibi/csv.sld @@ -0,0 +1,9 @@ + +(define-library (chibi csv) + (import (scheme base) (srfi 227)) + (export csv-grammar csv-parser csv-grammar? + default-csv-grammar default-tsv-grammar + csv-read->list csv-read->vector csv-read->fixed-vector + csv-read->sxml + csv-fold csv-map csv->list csv-for-each csv->sxml) + (include "csv.scm")) diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index f9cfb201..669529e9 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -32,6 +32,11 @@ ;;> If no patterns match an error is signalled. +;;> Note there is no \scheme{else} clause. \scheme{else} is sometimes +;;> used descriptively for the last pattern, since an identifier used +;;> only once matches anything, but it's preferred to use \scheme{_} +;;> described below. + ;;> Identifiers will match anything, and make the corresponding ;;> binding available in the body. @@ -128,7 +133,7 @@ ;;> are bound if the \scheme{or} operator matches, but the binding is ;;> only defined for identifiers from the subpattern which matched. -;;> \example{(match 1 ((or) #t) (else #f))} +;;> \example{(match 1 ((or) #t) (_ #f))} ;;> \example{(match 1 ((or x) x))} ;;> \example{(match 1 ((or x 2) x))} diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index fad9b498..5da914ab 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -1,5 +1,5 @@ ;; repl.scm - friendlier repl with line editing and signal handling -;; Copyright (c) 2012-2013 Alex Shinn. All rights reserved. +;; Copyright (c) 2012-2024 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt ;;> A user-friendly REPL with line editing and signal handling. The @@ -296,6 +296,8 @@ (pair? (exception-irritants exn))) (let ((name (car (exception-irritants exn)))) (cond + ((and (identifier? name) (not (env-parent (current-environment)))) + (display "Did you forget to import a language? e.g. (import (scheme base))\n" out)) ((identifier? name) (display "Searching for modules exporting " out) (display name out) @@ -400,6 +402,16 @@ ((= (length value) 1) (push-history-value! (car value))) (else (push-history-value! value)))) +(define-generic repl-print) + +(define-method (repl-print obj (out output-port?)) + (write/ss obj out)) + +(define-generic repl-print-exception) + +(define-method (repl-print-exception obj (out output-port?)) + (print-exception obj out)) + (define (repl/eval rp expr-list) (let ((thread (current-thread)) (out (repl-out rp))) @@ -409,7 +421,7 @@ (lambda () (protect (exn (else - (print-exception exn out) + (repl-print-exception exn out) (repl-advise-exception exn (current-error-port)))) (for-each (lambda (expr) @@ -420,17 +432,17 @@ (null? expr)) (eval expr (repl-env rp)) expr)) - (lambda res-list + (lambda res-values (cond - ((not (or (null? res-list) - (equal? res-list (list (if #f #f))))) - (push-history-value-maybe! res-list) - (write/ss (car res-list) out) + ((not (or (null? res-values) + (equal? res-values (list undefined-value)))) + (push-history-value-maybe! res-values) + (repl-print (car res-values) out) (for-each (lambda (res) (write-char #\space out) - (write/ss res out)) - (cdr res-list)) + (repl-print res out)) + (cdr res-values)) (newline out)))))) expr-list)))))) diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld index ae504cba..781bd1b5 100644 --- a/lib/chibi/repl.sld +++ b/lib/chibi/repl.sld @@ -1,8 +1,9 @@ (define-library (chibi repl) - (export repl $0 $1 $2 $3 $4 $5 $6 $7 $8 $9) + (export repl repl-print repl-print-exception + $0 $1 $2 $3 $4 $5 $6 $7 $8 $9) (import (chibi) (only (meta) load-module module-name->file) - (chibi ast) (chibi modules) (chibi doc) + (chibi ast) (chibi modules) (chibi doc) (chibi generic) (chibi string) (chibi io) (chibi optional) (chibi process) (chibi term edit-line) (srfi 1) diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index 81bd627b..9c1b5108 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -526,6 +526,7 @@ (not (assq-ref info 'line-number))) `((file-name . ,(car (pair-source expr))) (line-number . ,(cdr (pair-source expr))) + (format . ,(current-test-value-formatter)) ,@info) info))) @@ -584,14 +585,20 @@ ((SKIP) "-") (else ".")))) -(define (display-expected/actual expected actual) - (let* ((e-str (write-to-string expected)) - (a-str (write-to-string actual)) - (diff (diff e-str a-str read-char))) - (write-string "expected ") - (write-string (edits->string/color (car diff) (car (cddr diff)) 1)) - (write-string " but got ") - (write-string (edits->string/color (cadr diff) (car (cddr diff)) 2)))) +(define (display-expected/actual expected actual format) + (let ((e-str (format expected)) + (a-str (format actual))) + (if (and (equal? e-str a-str) + (not (eqv? format write-to-string))) + ;; If the formatter can't display any difference, fall back to + ;; write-to-string. + (display-expected/actual expected actual write-to-string) + (let ((diff (diff e-str a-str read-char))) + (write-string "expected ") + (write-string (edits->string/color (car diff) (car (cddr diff)) 1)) + (write-string " but got ") + (write-string (edits->string/color (cadr diff) (car (cddr diff)) 2)) + )))) (define (test-print-explanation indent status info) (cond @@ -617,8 +624,9 @@ (write (assq-ref info 'result))))) ((eq? status 'FAIL) (display indent) - (display-expected/actual - (assq-ref info 'expected) (assq-ref info 'result)))) + (display-expected/actual (assq-ref info 'expected) + (assq-ref info 'result) + (or (assq-ref info 'format) write-to-string)))) ;; print variables (cond ((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names)) @@ -863,6 +871,11 @@ ;;> \section{Parameters} +;;> If specified, takes a single object as input (the expected or +;;> actual value of a test) and returns the string representation +;;> (default \scheme{write-to-string}). +(define current-test-value-formatter (make-parameter #f)) + ;;> The current test group as started by \scheme{test-group} or ;;> \scheme{test-begin}. diff --git a/lib/chibi/test.sld b/lib/chibi/test.sld index 4aa039c3..b5eef726 100644 --- a/lib/chibi/test.sld +++ b/lib/chibi/test.sld @@ -10,7 +10,7 @@ test-get-name! test-group-name test-group-ref test-group-set! test-group-inc! test-group-push! ;; parameters - current-test-verbosity + current-test-value-formatter current-test-verbosity current-test-applier current-test-skipper current-test-reporter current-test-group-reporter test-failure-count current-test-epsilon current-test-comparator diff --git a/lib/srfi/35.sld b/lib/srfi/35.sld new file mode 100644 index 00000000..13c13c9a --- /dev/null +++ b/lib/srfi/35.sld @@ -0,0 +1,24 @@ +(define-library (srfi 35) + (import (srfi 35 internal)) + (export make-condition-type + condition-type? + make-condition + condition? + condition-has-type? + condition-ref + make-compound-condition + extract-condition + define-condition-type + condition + + &condition + + &message + message-condition? + condition-message + + &serious + serious-condition? + + &error + error?)) diff --git a/lib/srfi/35/internal.scm b/lib/srfi/35/internal.scm new file mode 100644 index 00000000..b8b94f6f --- /dev/null +++ b/lib/srfi/35/internal.scm @@ -0,0 +1,249 @@ +(define-record-type Simple-Condition + (make-simple-condition) + simple-condition?) + +(define-record-type Compound-Condition + (%make-compound-condition components) + compound-condition? + (components compound-condition-components)) + +(define (make-condition-type id parent field-names) + (make-rtd id + (list->vector + (map + (lambda (field-name) + (list 'immutable field-name)) + field-names)) + parent)) + +(define (condition? obj) + (or (simple-condition? obj) + (compound-condition? obj))) + +(define (condition-type? obj) + (condition-subtype? obj Simple-Condition)) + +(define (condition-subtype? maybe-child-ct maybe-parent-ct) + (and (rtd? maybe-child-ct) + (or (eqv? maybe-child-ct maybe-parent-ct) + (condition-subtype? (rtd-parent maybe-child-ct) + maybe-parent-ct)))) + +(define (condition-type-ancestors ct) + (unfold (lambda (a) (not (condition-type? a))) + (lambda (a) a) + (lambda (a) (rtd-parent a)) + ct)) + +(define (condition-type-common-ancestor ct_1 ct_2) + (let ((ct_1-as (condition-type-ancestors ct_1)) + (ct_2-as (condition-type-ancestors ct_2))) + (find (lambda (a) + (memv a ct_2-as)) + ct_1-as))) + +(define (make-condition ct . plist) + (define *undef* (cons '*undef* '())) + (let* ((field-names (rtd-all-field-names ct)) + (field-values (make-vector (vector-length field-names) *undef*))) + (let loop ((property plist)) + (if (null? property) + (cond ((vector-any (lambda (name value) + (and (eq? value *undef*) name)) + field-names + field-values) + => (lambda (undef-field-name) + (error "make-condition: value not given for field" + undef-field-name + ct))) + (else + (apply (rtd-constructor ct) (vector->list field-values)))) + (let ((idx (vector-index (lambda (x) (eq? x (car property))) + field-names))) + (if idx + (begin + (vector-set! field-values idx (cadr property)) + (loop (cddr property))) + (error "make-condition: unknown field" (car property)))))))) + +(define (make-compound-condition . cs) + (if (= (length cs) 1) + (car cs) + ;; SRFI 35 requires at least one component, but R6RS doesn’t; + ;; defer to R6RS’s less strict error checking (!) + (%make-compound-condition + (append-map + (lambda (c) + (if (simple-condition? c) + (list c) + (compound-condition-components c))) + cs)))) + +(define (condition-has-type? c ct) + (if (simple-condition? c) + (is-a? c ct) + (any + (lambda (comp) (condition-has-type? comp ct)) + (compound-condition-components c)))) + +(define (condition-ref c field-name) + (if (simple-condition? c) + ((rtd-accessor (record-rtd c) field-name) c) + (condition-ref + (find + (lambda (comp) + (find field-name + (vector->list + (rtd-all-field-names (record-rtd c))))) + (compound-condition-components c)) + field-name))) + +(define (simple-conditions c) + (if (simple-condition? c) + (list c) + (compound-condition-components c))) + +(define (extract-condition c ct) + (if (and (simple-condition? c) + (condition-has-type? c ct)) + c + (find + (lambda (comp) + (condition-has-type? comp ct)) + (compound-condition-components ct)))) + +(define (condition-predicate ct) + (lambda (obj) + (and (condition? obj) + (condition-has-type? obj ct)))) +(define (condition-accessor ct proc) + (lambda (c) + (cond ((and (simple-condition? c) + (condition-has-type? c ct)) + (proc c)) + ((find (lambda (comp) (condition-has-type? comp ct)) + (compound-condition-components c)) + => (lambda (comp) + (proc comp))) + (else (error "condition-accessor: condition does not have the right type" + c ct))))) + +(define-syntax define-condition-type/constructor + (syntax-rules () + ((_ name parent constructor predicate + (field-name field-accessor) ...) + (begin + (define ct (make-condition-type 'name + parent + '(field-name ...))) + (define name ct) + (define constructor (rtd-constructor ct)) + (define predicate (condition-predicate ct)) + (define field-accessor + (condition-accessor ct + (rtd-accessor ct 'field-name))) ...)))) + +(define-syntax define-condition-type + (syntax-rules () + ((_ name parent predicate (field-name field-accessor) ...) + (define-condition-type/constructor + name parent blah-ignored predicate + (field-name field-accessor) ...)))) + +(define (%condition . specs) + (define (find-common-field-spec ct name) + (let loop ((more-specs specs)) + (if (null? more-specs) + #f + (let* ((other-ct (caar more-specs)) + (field-specs (cdar more-specs)) + (a (condition-type-common-ancestor ct other-ct))) + (cond ((and (vector-index + (lambda (n) + (eq? n name)) + (rtd-all-field-names a)) + (assq name field-specs))) + (else (loop (cdr more-specs)))))))) + (let loop ((more-specs specs) + (components '())) + (if (null? more-specs) + (apply make-compound-condition (reverse components)) + (let* ((this-spec (car more-specs)) + (ct (car this-spec)) + (field-specs (cdr this-spec)) + (field-names (rtd-all-field-names ct)) + (field-values + (vector-map + (lambda (field-name) + (cond ((assq field-name field-specs) => cdr) + ((find-common-field-spec ct field-name) => cdr) + (else + (error "condition: value not given for field" + field-name + ct)))) + field-names))) + (loop + (cdr more-specs) + (cons + (apply (rtd-constructor ct) (vector->list field-values)) + components)))))) +(define-syntax condition + (syntax-rules () + ((_ (ct (field-name field-value) ...) ...) + (%condition (list ct (cons 'field-name field-value) ...) ...)))) + +(define &condition Simple-Condition) + +(define-condition-type/constructor &message &condition + make-message-condition message-condition? + (message condition-message)) + +(define-condition-type/constructor &serious &condition + make-serious-condition serious-condition?) + +(define-condition-type/constructor &error &serious + make-error error?) + +;; (chibi repl) support +(define-method (repl-print-exception (exn condition?) (out output-port?)) + (define components (simple-conditions exn)) + (define n-components (length components)) + (display "CONDITION: " out) + (display n-components out) + (display " component" out) + (if (not (= n-components 1)) (display "s" out)) + (display "\n" out) + (for-each + (lambda (component idx) + (define component-type (record-rtd component)) + (display " " out) + (display idx out) + (display ". " out) + (display (rtd-name component-type) out) + (display "\n" out) + (let loop ((as (reverse + (condition-type-ancestors component-type))) + (idx 0)) + (if (not (null? as)) + (let ((a (car as))) + (let a-loop ((fields (vector->list (rtd-field-names a))) + (idx idx)) + (if (null? fields) + (loop (cdr as) idx) + (begin + (display " " out) + (display (if (pair? (car fields)) + (car (cdar fields)) + (car fields)) + out) + (if (not (eqv? a component-type)) + (begin + (display " (" out) + (display (rtd-name a) out) + (display ")" out))) + (display ": " out) + (write (slot-ref component-type component idx) out) + (display "\n" out) + (a-loop (cdr fields) (+ idx 1))))))))) + components + (iota n-components 1))) diff --git a/lib/srfi/35/internal.sld b/lib/srfi/35/internal.sld new file mode 100644 index 00000000..0bc944a6 --- /dev/null +++ b/lib/srfi/35/internal.sld @@ -0,0 +1,48 @@ +(define-library (srfi 35 internal) + (import (except (scheme base) + define-record-type + ;; exclude (srfi 1 immutable) duplicate imports: + map cons list append reverse) + (scheme write) + (only (chibi) + slot-ref + is-a?) + (only (chibi repl) repl-print-exception) + (only (chibi generic) define-method) + ;; don’t let people go messing with a compound condition + ;; components list: + (srfi 1 immutable) + (srfi 99) + (srfi 133)) + (export make-condition-type + condition? + condition-type? + condition-subtype? + make-condition + make-compound-condition + condition-has-type? + condition-ref + simple-conditions + extract-condition + condition-predicate + condition-accessor + define-condition-type/constructor + define-condition-type + condition + + &condition + + &message + make-message-condition + message-condition? + condition-message + + &serious + make-serious-condition + serious-condition? + + &error + make-error + error?) + + (include "internal.scm")) diff --git a/lib/srfi/35/test.sld b/lib/srfi/35/test.sld new file mode 100644 index 00000000..aec2a63b --- /dev/null +++ b/lib/srfi/35/test.sld @@ -0,0 +1,94 @@ +(define-library (srfi 35 test) + (import (scheme base) + (srfi 35 internal) + (chibi test)) + (export run-tests) + (begin + (define (run-tests) + (test-begin "srfi-35: condition types") + (test-group "Adapted from the SRFI 35 examples" + (define-condition-type &c &condition + c? + (x c-x)) + + (define-condition-type &c1 &c + c1? + (a c1-a)) + + (define-condition-type &c2 &c + c2? + (b c2-b)) + (define v1 (make-condition &c1 'x "V1" 'a "a1")) + (define v2 (condition (&c2 + (x "V2") + (b "b2")))) + (define v3 (condition (&c1 + (x "V3/1") + (a "a3")) + (&c2 + (b "b3")))) + (define v4 (make-compound-condition v1 v2)) + (define v5 (make-compound-condition v2 v3)) + + (test #t (c? v1)) + (test #t (c1? v1)) + (test #f (c2? v1)) + (test "V1" (c-x v1)) + (test "a1" (c1-a v1)) + + (test #t (c? v2)) + (test #f (c1? v2)) + (test #t (c2? v2)) + (test "V2" (c-x v2)) + (test "b2" (c2-b v2)) + + (test #t (c? v3)) + (test #t (c1? v3)) + (test #t (c2? v3)) + (test "V3/1" (c-x v3)) + (test "a3" (c1-a v3)) + (test "b3" (c2-b v3)) + + (test #t (c? v4)) + (test #t (c1? v4)) + (test #t (c2? v4)) + (test "V1" (c-x v4)) + (test "a1" (c1-a v4)) + (test "b2" (c2-b v4)) + + (test #t (c? v5)) + (test #t (c1? v5)) + (test #t (c2? v5)) + (test "V2" (c-x v5)) + (test "a3" (c1-a v5)) + (test "b2" (c2-b v5))) + + (test-group "Standard condition hierarchy" + (let ((mc (make-message-condition "foo!"))) + (test #t (message-condition? mc)) + (test "foo!" (condition-message mc)) + + (let ((ec (make-error))) + (test #t (error? ec)) + (test #t (serious-condition? ec)) + + (let ((cc (make-compound-condition ec mc))) + (test #t (error? cc)) + (test #t (serious-condition? cc)) + (test #t (message-condition? cc)) + (test "foo!" (condition-message mc)))))) + + (test-group "R6RS extension: shadowing field names" + (define-condition-type/constructor &a &condition + make-a a? + (val a-val)) + (define-condition-type/constructor &b &a + make-b b? + (val b-val)) + + (define c (make-b 'a 'b)) + + (test 'a (a-val c)) + (test 'b (b-val c))) + + (test-end)))) diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm index e213242d..16201c3e 100644 --- a/lib/srfi/99/records/procedural.scm +++ b/lib/srfi/99/records/procedural.scm @@ -9,7 +9,13 @@ (type? x)) (define (rtd-constructor rtd . o) - (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd)))) + (let ((fields + (if (pair? o) + (map + (lambda (field) + (rtd-field-offset rtd field)) + (vector->list (car o))) + (iota (vector-length (rtd-all-field-names rtd))))) (make (make-constructor (type-name rtd) rtd))) (lambda args (let ((res (make))) @@ -18,7 +24,7 @@ ((null? a) (if (null? p) res (error "not enough args" p))) ((null? p) (error "too many args" a)) (else - (slot-set! rtd res (rtd-field-offset rtd (car p)) (car a)) + (slot-set! rtd res (car p) (car a)) (lp (cdr a) (cdr p))))))))) (define (rtd-predicate rtd) @@ -35,13 +41,13 @@ (define (rtd-field-offset rtd field) (let ((p (type-parent rtd))) - (or (and (type? p) - (rtd-field-offset p field)) - (let ((i (field-index-of (type-slots rtd) field))) + (or (let ((i (field-index-of (type-slots rtd) field))) (and i (if (type? p) (+ i (vector-length (rtd-all-field-names p))) - i)))))) + i))) + (and (type? p) + (rtd-field-offset p field))))) (define (rtd-accessor rtd field) (make-getter (type-name rtd) rtd (rtd-field-offset rtd field))) diff --git a/lib/srfi/99/records/procedural.sld b/lib/srfi/99/records/procedural.sld index b5791992..05a31616 100644 --- a/lib/srfi/99/records/procedural.sld +++ b/lib/srfi/99/records/procedural.sld @@ -1,5 +1,8 @@ (define-library (srfi 99 records procedural) (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator) - (import (chibi) (chibi ast) (srfi 99 records inspection)) + (import (chibi) + (chibi ast) + (only (srfi 1) iota) + (srfi 99 records inspection)) (include "procedural.scm")) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 38c044bc..612d2884 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -8,6 +8,7 @@ (rename (srfi 18 test) (run-tests run-srfi-18-tests)) (rename (srfi 26 test) (run-tests run-srfi-26-tests)) (rename (srfi 27 test) (run-tests run-srfi-27-tests)) + (rename (srfi 35 test) (run-tests run-srfi-35-tests)) (rename (srfi 38 test) (run-tests run-srfi-38-tests)) (rename (srfi 41 test) (run-tests run-srfi-41-tests)) (rename (srfi 69 test) (run-tests run-srfi-69-tests)) @@ -83,6 +84,7 @@ (run-srfi-18-tests) (run-srfi-26-tests) (run-srfi-27-tests) +(run-srfi-35-tests) (run-srfi-38-tests) (run-srfi-41-tests) (run-srfi-69-tests)