New test system

Makefile

@@ -97,7 +97,11 @@ track : $(track-requirements)
 
 # send a list of implementations to run stub-makefile tests on
 ci :
-	echo "(run-ci '($(implementations)))" | $(chez) -q "script/ci.ss"
+	#echo "(run-ci '($(implementations)))" | $(chez) -q "script/ci.ss"
+	# The acronym example code only works for guile.  Currently, examples
+	# must pass for both chez and guile.  list-ops and robot-name are both
+	# deprecated anyway.
+	echo "(run-all-tests 'list-ops 'robot-name 'acronym)" | $(chez) -q script/ci.ss
 
 clean :
 	find . -name "*.so" -exec rm {} \;

code/test-migration.ss

@@ -0,0 +1,136 @@
+(import (chezscheme))
+
+(define (read-all-map-maybe p src)
+  (with-input-from-file src
+    (lambda ()
+      (let rec ((ys '()))
+        (let ((x (read)))
+          (if (eof-object? x) ys
+              (let ((y (p x)))
+                (rec (if y (cons y ys) ys)))))))))
+
+(define (definition? x)
+  (and (list? x)
+       (>= (length x) 2)
+       (equal? (car x) 'define)))
+
+(define (stub? x)
+  (and (definition? x) (= (length x) 2)))
+
+(define (definition-name? name def)
+  (let ((ident (cadr def)))
+    (cond
+     ((symbol? ident) (equal? name ident))
+     ((pair? ident) (equal? name (car ident)))
+     (else #f))))
+
+(define (test-runner? x)
+  (and (list? x) (= 3 (length x))
+       (equal? (car x) 'let)
+       (equal? (cadr x) '((args (command-line))))))
+
+(define (legacy-import? x)
+  (equal? x '(import (except (rnrs) current-output-port))))
+
+;; Predicate for things that should still be in the test.scm file.
+;; This includes things we don't know about like extra predicates for the tests.
+;; That is why it is defined in the negative.
+(define (relevant? x)
+  (not (obsolete? x)))
+
+;; Predicate for all the things that shouldn't be in
+;; the test.scm file anymore.
+(define (obsolete? x)
+  (or (stub? x)
+      (test-runner? x)
+      (legacy-import? x)
+      (definition-name? 'test x)
+      (definition-name? 'run-docker x)
+      (definition-name? 'run-test-suite x)
+      (definition-name? 'test-error x)
+      (definition-name? 'test-success x)
+      (definition-name? 'test-run-solution x)
+      (definition-name? 'test-fields x)))
+
+
+(define load-statement '(load "test-util.ss"))
+(define (test-statement slug)
+  `(run-with-cli ,(format "~a.scm" slug) (list test-cases)))
+
+(define (migrate-test-cases cases)
+  (unless (definition-name? 'test-cases cases)
+    (error 'migrate-test-cases
+           "~s is not the test-cases definition" cases))
+  `(define test-cases
+     ,(list 'quasiquote (map caddr (cdaddr cases)))))
+
+(define (cdr-or x y)
+  (if (pair? x) (cdr x) y))
+
+;; We end up with 2 trailing newlines.
+(define (migrate-file src . args)
+  (let ((slug (cdr-or (assoc 'slug args) 'solution))
+        (body-parts
+         (read-all-map-maybe
+          (lambda (x)
+            (and (relevant? x)
+                 (if (definition-name? 'test-cases x)
+                     (migrate-test-cases x)
+                     x)))
+          src)))
+    (delete-file src)
+    (with-output-to-file src
+      (lambda ()
+        (for-each
+         (lambda (x) (pretty-print x) (newline))
+         (cons load-statement
+               (reverse
+                (cons (test-statement slug)
+                      body-parts))))))))
+
+(define (slug->directory slug . args)
+  (let ((kind (cdr-or (assoc 'kind args) 'practice)))
+   (format "exercises/~a/~a/" kind slug)))
+
+(define (append-path base ext)
+  (unless (char=? #\/ (string-ref base (1- (string-length base))))
+    (set! base (string-append base "/")))
+  (format "~a~a" base ext))
+
+(define (filename path)
+  (let ((last-sep-idx
+         (fold-left
+          (lambda (last x)
+            (or (and (char=? #\/ (cdr x)) (car x))
+                last))
+          #f (map cons (iota (string-length path))
+                  (string->list path)))))
+    (if (not last-sep-idx) path
+        (substring path (1+ last-sep-idx) (string-length path)))))
+
+(define (copy-file from to)
+  (when (file-directory? to)
+    (set! to (append-path to (filename from))))
+  (when (file-exists? to)
+    (delete-file to))
+  (with-input-from-file from
+    (lambda ()
+      (with-output-to-file to
+        (lambda ()
+          (do ((chunk (get-string-n (current-input-port) 1024)
+                      (get-string-n (current-input-port) 1024)))
+              ((eof-object? chunk))
+            (put-string (current-output-port) chunk)))))))
+
+(define (migrate-exercise slug . args)
+  (let* ((kind (cdr-or (assoc 'kind args) 'practice))
+         (dir (slug->directory slug `(kind . ,kind))))
+    (copy-file "input/test-util.ss" dir)
+    (migrate-file (append-path dir "test.scm") `(slug . ,slug))))
+
+(define (deploy-new-test-util)
+  (for-each
+   (lambda (slug)
+     (copy-file "input/test-util.ss"
+                (slug->directory slug)))
+   (directory-list "exercises/practice/")))

config.json

@@ -23,7 +23,8 @@
       "%{kebab_slug}.scm"
     ],
     "test": [
-      "test.scm"
+      "test.scm",
+      "test-util.ss"
     ],
     "example": [
       "example.scm"

exercises/practice/accumulate/.meta/config.json

@@ -1,5 +1,4 @@
 {
-  "blurb": "Implement the `accumulate` operation, which, given a collection and an operation to perform on each element of the collection, returns a new collection containing the result of applying that operation to each element of the input collection.",
   "authors": [
     "tongkiat"
   ],
@@ -8,12 +7,14 @@
       "accumulate.scm"
     ],
     "test": [
-      "test.scm"
+      "test.scm",
+      "test-util.ss"
     ],
     "example": [
       ".meta/example.scm"
     ]
   },
+  "blurb": "Implement the `accumulate` operation, which, given a collection and an operation to perform on each element of the collection, returns a new collection containing the result of applying that operation to each element of the input collection.",
   "source": "Conversation with James Edward Gray II",
   "source_url": "https://twitter.com/jeg2"
 }

exercises/practice/accumulate/test-util.ss

@@ -0,0 +1,162 @@
+(import (except (rnrs) current-output-port))
+
+(define test-fields '(input expected actual))
+
+(define (test-run-solution solution input)
+  (if (procedure? solution) (apply solution input) solution))
+
+(define (scheme->string o)
+  (with-output-to-string
+    (lambda ()
+      (write o))))
+
+(define (process-condition e)
+  (if (not (condition? e)) e
+      `(error
+        ,(if (who-condition? e) (condition-who e)
+             'unknown)
+        ,(condition-message e)
+        ,@(if (not (irritants-condition? e)) '()
+              (condition-irritants e)))))
+
+(define (test-success description success-predicate
+                      procedure input expected code)
+  (call/cc
+   (lambda (k)
+     (let ([out (open-output-string)])
+       (dynamic-wind
+         (lambda () (set! out (open-output-string)))
+         (lambda ()
+           (with-exception-handler
+               (lambda (e)
+                 (k `(fail
+                      (description . ,description)
+                      (code . ,code)
+                      (input . ,input)
+                      (expected . ,expected)
+                      (actual . ,(process-condition e))
+                      (stdout . ,(get-output-string out)))))
+             (lambda ()
+               (let ([result (parameterize ([current-output-port out])
+                               (test-run-solution procedure input))])
+                 (unless (success-predicate result expected)
+                   (raise result))
+                 `(pass
+                   (description . ,description)
+                   (code . ,code)
+                   (stdout . ,(get-output-string out)))))))
+         (lambda () (close-output-port out)))))))
+
+(define (test-error description procedure input code)
+  (call/cc
+    (lambda (k)
+      (let ([out '()])
+        (dynamic-wind
+          (lambda () (set! out (open-output-string)))
+          (lambda ()
+            (with-exception-handler
+                (lambda (e)
+                  (k `(pass
+                       (description . ,description)
+                       (code . ,code)
+                       (stdout . ,(get-output-string out)))))
+              (lambda ()
+                (let ((result (parameterize ([current-output-port out])
+                                (test-run-solution procedure input))))
+                  `(fail
+                    (description . ,description)
+                    (code . ,code)
+                    (input . ,input)
+                    (expected . error)
+                    (actual . ,result)
+                    (stdout . ,(get-output-string out)))))))
+          (lambda () (close-output-port out)))))))
+
+(define (run-test test)
+  (eval (append test `((quote ,test))) (interaction-environment)))
+
+(define (run-test-suite tests . query)
+  (for-each
+    (lambda (field)
+      (unless (and (symbol? field) (memq field test-fields))
+        (error 'run-test-suite
+          (format #t "~a not in ~a" field test-fields))))
+    query)
+  (let-values ([(passes failures)
+                (partition
+                  (lambda (result) (eq? 'pass (car result)))
+                  (map run-test tests))])
+    (cond
+      [(null? failures) (format #t "~%Well done!~%~%")]
+      [else
+       (format
+         #t
+         "~%Passed ~a/~a tests.~%~%The following test cases failed:~%~%"
+         (length passes)
+         (length tests))
+       (for-each
+         (lambda (failure)
+           (format
+             #t
+             "* ~a~%"
+             (cond
+               [(assoc 'description (cdr failure)) => cdr]
+               [else (cdr failure)]))
+           (for-each
+             (lambda (field)
+               (let ([info (assoc field (cdr failure))])
+                 (display "  - ")
+                 (write (car info))
+                 (display ": ")
+                 (write (cdr info))
+                 (newline)))
+             query))
+         failures)
+       (error 'test "incorrect solution")])))
+
+
+(define (run-docker suite)
+  (write (map run-test suite)))
+
+(define (test suite . query)
+  (apply run-test-suite suite query))
+
+(define (tests suites . query)
+  (for-each (lambda (suite) (apply test suite query)) suites))
+
+(define (run-with-cli solution suites)
+  (let ((args (command-line)))
+    (cond
+     ;; Normal execution.  This is the default behavior used by students
+     ;; running their tests locally.
+     [(null? (cdr args))
+      (load solution)
+      (tests suites 'input 'expected 'actual)]
+     ;; Scheme programs ingesting this output can expect an alist with
+     ;; the keys 'test-lib-version and 'status.  No test-lib version
+     ;; means an older version of these test utilities is in use, so there
+     ;; will only be pass/fail lists in the output.  When status is 'error,
+     ;; A message is provided for explanation. It is usually a stringified
+     ;; condition.  When status is 'completed everything is normal, and the
+     ;; rest of the list comsists of pass/fail lists.
+     [(string=? (cadr args) "--docker")
+      (write
+       `((test-lib-version . 1)
+         ,@(call/cc
+            (lambda (k)
+              (with-exception-handler
+                  ;; Catch failures while loading/compiling the solution.
+                  (lambda (e)
+                    (k `((status . error)
+                         (message
+                          . ,(string-append
+                              "Failed with value: "
+                              (scheme->string (process-condition e)))))))
+                (lambda ()
+                  (load solution)
+                  `((status . ok)
+                    ,@(fold-left (lambda (results suite)
+                                   (append results (map run-test suite)))
+                                 '()  suites))))))))]
+     ;; You can pass the name of a file to load instead of the "expected" solution filename.
+     [else (load (cadr args)) (tests suites 'input 'expected 'actual)])))