[functional-tests] Tests are now identified by a list of symbols.

Improved formatting too.

functional-tests/functional-tests.scm

@@ -27,21 +27,13 @@
   (import
     (chezscheme)
     (fmt fmt)
+    (list-utils)
     (thin-xml)
     (srfi s8 receive)
     (only (srfi s1 lists) drop-while))
 
   ;;;--------------------------------------------------------------------
 
-  ;;; FIXME: there must be an equivalent of this in srfi 1
-  (define (intersperse sep xs)
-    (cond
-      ((null? xs) '())
-      ((null? (cdr xs)) xs)
-      (else (cons (car xs)
-                  (cons sep
-                        (intersperse sep (cdr xs)))))))
-
   (define (vector-sort-by cmp key-fn v)
     (define (compare x y)
       (cmp (key-fn x) (key-fn y)))
@@ -137,28 +129,59 @@
 
   (define-record-type scenario (fields desc thunk))
 
-  (define scenarios (make-eq-hashtable))
+  (define scenarios
+    (make-hashtable equal-hash equal?))
 
-  (define (add-scenario sym s)
+  (define (add-scenario syms s)
-    (hashtable-set! scenarios sym s))
+    (hashtable-set! scenarios syms s))
+
+  (define (fmt-keys prev-keys keys)
+    (define (fmt-keys% n keys)
+      (if (null? keys)
+          fmt-null
+          (cat (space-to n) (dsp (car keys)) (if (null? (cdr keys)) fmt-null nl)
+               (fmt-keys% (+ n 2) (cdr keys)))))
+
+    (let loop ((n 0)
+               (keys keys)
+               (prev-keys prev-keys))
+      (if (and (not (null? keys))
+               (not (null? prev-keys))
+               (eq? (car keys) (car prev-keys)))
+          (loop (+ n 2) (cdr keys) (cdr prev-keys))
+          (begin
+            (if (zero? n)
+              (cat nl (fmt-keys% n keys))
+              (fmt-keys% n keys))))))
 
   (define (list-scenarios)
+    (define (fmt-keys ks)
+      (fmt #f (dsp ks)))
+
     (vector->list
-      (vector-sort-by string<? symbol->string (hashtable-keys scenarios))))
+      (vector-sort-by string<? fmt-keys (hashtable-keys scenarios))))
 
-  (define (describe-scenarios ss)
+  (define (fmt-scenarios keys fn)
-    (define (describe sym)
+    (define (describe prev-keys keys)
       (fmt #t
-           (columnar (dsp sym)
+           (cat (fmt-keys prev-keys keys)
-                     (justify (scenario-desc (hashtable-ref scenarios sym #f))))
+                (pad-char #\.
-           nl))
+                          (space-to 40)
+                          (fn keys))
+                nl)))
 
-    (for-each describe ss))
+    (for-each describe (cons '() (reverse (cdr (reverse keys)))) keys))
+
+  (define (describe-scenarios keys)
+    (fmt-scenarios keys
+                   (lambda (keys)
+                     (scenario-desc
+                       (hashtable-ref scenarios keys #f)))))
 
   (define-syntax define-scenario
     (syntax-rules ()
-      ((_ sym desc body ...)
+      ((_ syms desc body ...)
-       (add-scenario 'sym
+       (add-scenario 'syms
                      (make-scenario desc
                                     (lambda ()
                                       body ...))))))
@@ -168,14 +191,18 @@
              (make-error)
              (make-message-condition msg))))
 
-  (define (run-scenario sym)
+  (define (run-scenario syms)
-    (let ((s (hashtable-ref scenarios sym #f)))
+    (let ((s (hashtable-ref scenarios syms #f)))
-     (display sym)
+     (display syms)
      (display " ... ")
      ((scenario-thunk s))
      (display "pass")
      (newline)))
 
   (define (run-scenarios ss)
-    (for-each run-scenario ss)))
+    (fmt-scenarios ss
+                   (lambda (keys)
+                     (let ((s (hashtable-ref scenarios keys #f)))
+                      ((scenario-thunk s))
+                      (dsp "pass"))))))
 

functional-tests/list-utils.scm

@@ -1,7 +1,15 @@
 (library
   (list-utils)
-  (export tails intersperse iterate accumulate)
+
-  (import (rnrs))
+  (export tails
+          intersperse
+          iterate
+          comparing
+          list-group-by
+          accumulate)
+
+  (import (rnrs)
+          (srfi s8 receive))
 
   (define (tails xs)
     (if (null? xs)
@@ -22,6 +30,19 @@
         '()
         (cons (fn) (loop (- count 1))))))
 
+  (define (comparing cmp key)
+    (lambda (x y)
+      (cmp (key x) (key y))))
+
+  ;; Assumes the list is already sorted
+  (define (list-group-by pred xs)
+    (if (null? xs)
+        '()
+        (let ((fst (car xs)))
+         (receive (g1 gs) (partition (lambda (x) (pred fst x)) (cdr xs))
+                  (cons (cons fst g1)
+                        (list-group-by pred gs))))))
+
   ;; calculates a running total for a list.  Returns a list.
   (define (accumulate xs)
     (let loop ((xs xs) (total 0))

functional-tests/thin-functional-tests.scm

@@ -119,58 +119,58 @@ Where:
   <block range> is of the form <begin>..<one-past-the-end>
   for example 5..45 denotes blocks 5 to 44 inclusive, but not block 45")
 
-  (define-scenario thin-check-v
+  (define-scenario (thin-check v)
                    "thin_check -V"
                    (receive (stdout _) (thin-check "-V")
                             (assert-equal tools-version stdout)))
 
-  (define-scenario thin-check-version
+  (define-scenario (thin-check version)
             "thin_check --version"
             (receive (stdout _) (thin-check "--version")
                      (assert-equal tools-version stdout)))
 
-  (define-scenario thin-check-h
+  (define-scenario (thin-check h)
             "print help (-h)"
             (receive (stdout _) (thin-check "-h")
                      (assert-equal thin-check-help stdout)))
 
-  (define-scenario thin-check-help
+  (define-scenario (thin-check help)
             "print help (--help)"
             (receive (stdout _) (thin-check "--help")
                      (assert-equal thin-check-help stdout)))
 
-  (define-scenario thin-check-bad-option
+  (define-scenario (thin-check bad-option)
             "Unrecognised option should cause failure"
             (run-fail "thin_check --hedgehogs-only"))
 
-  (define-scenario thin-check-superblock-only-valid
+  (define-scenario (thin-check superblock-only-valid)
             "--super-block-only check passes on valid metadata"
             (with-valid-metadata
               (thin-check "--super-block-only" (current-metadata))))
 
-  (define-scenario thin-check-superblock-only-invalid
+  (define-scenario (thin-check superblock-only-invalid)
             "--super-block-only check fails with corrupt metadata"
             (with-corrupt-metadata
               (run-fail "thin_check --super-block-only" (current-metadata))))
 
-  (define-scenario thin-check-skip-mappings-valid
+  (define-scenario (thin-check skip-mappings-valid)
             "--skip-mappings check passes on valid metadata"
             (with-valid-metadata
               (thin-check "--skip-mappings" (current-metadata))))
 
-  (define-scenario thin-check-ignore-non-fatal-errors
+  (define-scenario (thin-check ignore-non-fatal-errors)
             "--ignore-non-fatal-errors check passes on valid metadata"
             (with-valid-metadata
               (thin-check "--ignore-non-fatal-errors" (current-metadata))))
 
-  (define-scenario thin-check-quiet
+  (define-scenario (thin-check quiet)
             "--quiet should give no output"
             (with-valid-metadata
               (receive (stdout stderr) (thin-check "--quiet" (current-metadata))
                        (assert-eof stdout)
                        (assert-eof stderr))))
 
-  (define-scenario thin-check-clear-needs-check-flag
+  (define-scenario (thin-check clear-needs-check-flag)
             "Accepts --clear-needs-check-flag"
             (with-valid-metadata
               (thin-check "--clear-needs-check-flag" (current-metadata))))
@@ -179,59 +179,59 @@ Where:
   ;;; thin_restore scenarios
   ;;;-----------------------------------------------------------
 
-  (define-scenario thin-restore-print-version-v
+  (define-scenario (thin-restore print-version-v)
                    "print help (-V)"
                    (receive (stdout _) (thin-restore "-V")
                             (assert-equal tools-version stdout)))
 
-  (define-scenario thin-restore-print-version-long
+  (define-scenario (thin-restore print-version-long)
             "print help (--version)"
             (receive (stdout _) (thin-restore "--version")
                      (assert-equal tools-version stdout)))
 
-  (define-scenario thin-restore-h
+  (define-scenario (thin-restore h)
             "print help (-h)"
             (receive (stdout _) (thin-restore "-h")
                      (assert-equal thin-restore-help stdout)))
 
-  (define-scenario thin-restore-help
+  (define-scenario (thin-restore help)
             "print help (-h)"
             (receive (stdout _) (thin-restore "--help")
                      (assert-equal thin-restore-help stdout)))
 
-  (define-scenario thin-restore-no-input-file
+  (define-scenario (thin-restore no-input-file)
             "forget to specify an input file"
             (receive (_ stderr) (run-fail "thin_restore" "-o" (current-metadata))
                      (assert-starts-with "No input file provided." stderr)))
 
-  (define-scenario thin-restore-missing-input-file
+  (define-scenario (thin-restore missing-input-file)
             "the input file can't be found"
             (receive (_ stderr) (run-fail "thin_restore -i no-such-file -o" (current-metadata))
                      (assert-starts-with "Couldn't stat file" stderr)))
 
-  (define-scenario thin-restore-missing-output-file
+  (define-scenario (thin-restore missing-output-file)
             "the input file can't be found"
             (receive (_ stderr) (run-fail "thin_restore -i no-such-file -o" (current-metadata))
                      (assert-starts-with "Couldn't stat file" stderr)))
 
-  (define-scenario thin-restore-tiny-output-file
+  (define-scenario (thin-restore tiny-output-file)
                    "Fails if the output file is too small."
                    (let ((outfile (temp-file)))
                     (run-ok "dd if=/dev/zero" (fmt #f (dsp "of=") (dsp outfile)) "bs=4k count=1")
                     (receive (_ stderr) (run-fail "thin_restore" "-i" (temp-thin-xml) "-o" outfile)
                              (assert-starts-with thin-restore-outfile-too-small-text stderr))))
 
-  (define-scenario thin-restore-q
+  (define-scenario (thin-restore q)
             "thin_restore accepts -q"
             (receive (stdout _) (thin-restore "-i" (temp-thin-xml) "-o" (current-metadata) "-q")
                      (assert-eof stdout)))
 
-  (define-scenario thin-restore-quiet
+  (define-scenario (thin-restore quiet)
             "thin_restore accepts --quiet"
             (receive (stdout _) (thin-restore "-i" (temp-thin-xml) "-o" (current-metadata) "--quiet")
                      (assert-eof stdout)))
 
-  (define-scenario thin-dump-restore-is-noop
+  (define-scenario (thin-dump restore-is-noop)
             "thin_dump followed by thin_restore is a noop."
             (with-valid-metadata
               (receive (d1-stdout _) (thin-dump (current-metadata))
@@ -243,43 +243,43 @@ Where:
   ;;; thin_rmap scenarios
   ;;;-----------------------------------------------------------
 
-  (define-scenario thin-rmap-v
+  (define-scenario (thin-rmap v)
             "thin_rmap accepts -V"
             (receive (stdout _) (thin-rmap "-V")
                      (assert-equal tools-version stdout)))
 
-  (define-scenario thin-rmap-version
+  (define-scenario (thin-rmap version)
             "thin_rmap accepts --version"
             (receive (stdout _) (thin-rmap "--version")
                      (assert-equal tools-version stdout)))
 
-  (define-scenario thin-rmap-h
+  (define-scenario (thin-rmap h)
                    "thin_rmap accepts -h"
                    (receive (stdout _) (thin-rmap "-h")
                             (assert-equal thin-rmap-help stdout)))
 
-  (define-scenario thin-rmap-help
+  (define-scenario (thin-rmap help)
             "thin_rmap accepts --help"
             (receive (stdout _) (thin-rmap "--help")
                      (assert-equal thin-rmap-help stdout)))
 
-  (define-scenario thin-rmap-unrecognised-flag
+  (define-scenario (thin-rmap unrecognised-flag)
             "thin_rmap complains with bad flags."
             (run-fail "thin_rmap --unleash-the-hedgehogs"))
 
-  (define-scenario thin-rmap-valid-region-format-should-pass
+  (define-scenario (thin-rmap valid-region-format-should-pass)
             "thin_rmap with a valid region format should pass."
             (with-valid-metadata
               (thin-rmap "--region 23..7890" (current-metadata))))
 
-  (define-scenario thin-rmap-invalid-region-should-fail
+  (define-scenario (thin-rmap invalid-region-should-fail)
             "thin_rmap with an invalid region format should fail."
             (for-each (lambda (pattern)
                         (with-valid-metadata
                           (run-fail "thin_rmap --region" pattern (current-metadata))))
                       '("23,7890" "23..six" "found..7890" "89..88" "89..89" "89.." "" "89...99")))
 
-  (define-scenario thin-rmap-multiple-regions-should-pass
+  (define-scenario (thin-rmap multiple-regions-should-pass)
             "thin_rmap should handle multiple regions."
             (with-valid-metadata
               (thin-rmap "--region 1..23 --region 45..78" (current-metadata)))))