1
\$\begingroup\$

As an exercise in learning how to use Racket macros I decided to implement a subset of the features in the catch test framework for C++. In particular the catch test framework has a unique feature that I haven't seen in other frameworks called "sections" that implement an interesting form of control flow.

In C++ this is all done with preprocessor macros, which means if you screw up you get really obscure errors. I figured this would be a good demonstrative case of the advantages of the a advanced macro system.

The section control flow works as follows. First you wrap your entire test case and give it a name:

(test-case "my_test"
    ;; body goes here)

Then inside the test case, you can insert arbitrary code, including sections:

(test-case "my_test"
  (do-some-test-setup)
  (define useful-variable-need-by-tests #f)
  (section "x"
           (some-code)
           (more-code-using-useful-variable))
  (section "a"
           (set-up-stuff-specific-to-this-section)
           (section "b"
                    (b-stuff))
           (section "c"
               (c-stuff))))

When you run this code, the body of the test will actually run multiple times. The first time the test runs, section x will execute but section a will be skipped. The second time the test runs section x will be skipped, section a will run, section b will run, and section c will be skipped. The final time it runs section x will be skipped, section a will run, section b will be skipped, and section c will run. In other words the sections form a tree that we do a depth-first traversal on.

Additionally, catch has two macros for asserting things that should be true, called check and require. A failed require will abort the test, but a failed check will simply be recorded and reported at the end of the test.

There are some more things that the full-featured C++ framework can do, but this is all I have implemented for a start. This is my first real racket project, so I expect I'm doing a bunch of stuff less than ideally. I'd also be especially interested in suggestions about how to make it more functional -- I'm leaning pretty heavily on mutation in a number of places.

#lang typed/racket

;; TODO: how to centrally register all test cases?

(require (for-syntax syntax/parse))
(require racket/stxparam)
(require data/queue)

(provide test-case section catch-check catch-require exn:catch-require-failure)

(define-syntax (test-case-parameter stx)
  (syntax-parse stx
    [(_ parameter:id ...)
     #'(begin
         (define-syntax-parameter parameter
           (lambda (stx)
             (raise-syntax-error stx "Can only be used inside test-case."))) ...)]))

(test-case-parameter section catch-require catch-check)

(struct section-info
  ([child-count : Integer]
   [active-child : Integer])
  #:mutable)

(struct check-failure
  ([filename : String]
   [line-number : Integer]
   [section-name : String]
   [expression : String])
  #:transparent)

(define section-table : (Parameterof (HashTable String section-info)) (make-parameter (make-hash (list (cons "" (section-info 0 0))))))
(define parent-name : (Parameterof String) (make-parameter ""))
(define parent-ran-child-section : (Parameterof Boolean) (make-parameter #f))
(define parents-child-counter : (Parameterof Integer) (make-parameter 0))
(define check-failures : (Parameterof (Listof check-failure)) (make-parameter empty)) ;; wrong data structure, shouldn't have to reverse at the end
(define suppress-output : (Parameterof Boolean) (make-parameter #f))

(: while-loop (All (A) (-> (-> Boolean) (-> A) Void)))
(define (while-loop condition action)
  (when (condition)
    (action)
    (while-loop condition action))
  (void))

(define-syntax (while stx)
  (syntax-parse stx
    [(_ condition:expr body0:expr body:expr ...)
     #'(while-loop (lambda () condition) (lambda () body0 body ...))]))

(define-syntax (do-while stx)
  (syntax-parse stx
    [(_ condition:expr body0:expr body:expr ...)
     #'(begin
         (define actions (lambda () body0 body ...))
         (actions)
         (while-loop (lambda () condition) actions))]))

(module+ test
  (define i : Integer 0)
  (while (< i 10)
    (set! i (add1 i)))
  (unless (= 10 i)
    (error "While implementation broken.")))

(define-syntax (debug-print stx)
  (syntax-parse stx
    [(_ x:expr ...) #'(begin (println (format "~a: ~a" 'x x)) ...)]))

(struct exn:catch-require-failure exn:fail ())

(define-for-syntax (catch-require-impl stx)
  (with-syntax ([filename (syntax-source stx)]
                [line-number (syntax-line stx)])
    (syntax-parse stx
      [(_ e:expr)
       #'(unless e
           (raise (exn:catch-require-failure
                   (format "~a:~a: catch-require failure: ~a" filename line-number 'e)
                   (current-continuation-marks))))])))

(module+ test
  (define require-raised-exception : Boolean #f)
  (with-handlers ([exn:catch-require-failure? (lambda (e)
                                                (set! require-raised-exception #t))])
    (test-case "require test that will fail"
      (catch-require (= 2 3))))
  (unless require-raised-exception
    (error "catch-require not throwing as expected!")))

(define-for-syntax (catch-check-impl stx)
  (with-syntax ([filename (syntax-source stx)]
                [line-number (syntax-line stx)])
    (syntax-parse stx
      [(_ e:expr)
       #'(unless e
           (check-failures (cons (check-failure (~a filename) line-number (parent-name) (~a 'e))
                                 (check-failures))))])))

(define (report-failures)
  (for ([i (reverse (check-failures))])
    (printf "~a:~a: check failed in section \"~a\": ~a\n"
            (check-failure-filename i)
            (check-failure-line-number i)
            (check-failure-section-name i)
            (check-failure-expression i))))

(module+ test
  (parameterize ([suppress-output #t])
    ;; TODO: not sure why I'm getting a dead code warning here
    (test-case "check test that will fail"
      (section "wtf"
               (catch-check (= 2 3))
               (catch-check (= 0 3))
               )
      (unless (equal? (~a (check-failure-expression (car (check-failures)))) (~a '(= 0 3)))
        (error "catch-check not accumulating results as expected!"))
      (unless (equal? (~a (check-failure-expression (car (check-failures)))) (~a '(= 2 3)))
        (error "catch-check not accumulating results as expected!")))))

(define-for-syntax (section-impl stx)
  (syntax-parse stx
    [(_ name:str body0:expr body:expr ...)
     #'(begin
         (define parent-info (hash-ref (section-table) (parent-name)))
         (define full-name (string-append (parent-name) "/" name))
         (define info (hash-ref! (section-table) full-name
                                 (lambda ()
                                   (set-section-info-child-count! parent-info (add1 (section-info-child-count parent-info)))
                                   (section-info 0 0))))
         (when (and (= (parents-child-counter) (section-info-active-child parent-info))
                    (not (parent-ran-child-section)))
           (define child-counter : Integer 0)
           (define ran-section : Boolean #f)
           (parameterize ([parent-name full-name]
                          [parent-ran-child-section ran-section]
                          [parents-child-counter child-counter])
             body0
             body ...)
           (when (= (section-info-child-count info) (section-info-active-child info))
             (set-section-info-active-child! parent-info (add1 (section-info-active-child parent-info))))
           (parent-ran-child-section #t))
         (parents-child-counter (add1 (parents-child-counter))))]))

;; TODO: count check successes and failures
(define-syntax (test-case stx)
  (syntax-parse stx
    [(_ name:str body0:expr body:expr ...)
     #'(begin
         (define root-name : String name)
         (define root-info : section-info (section-info 0 0))
         (define table : (HashTable String section-info) (make-hash (list (cons root-name root-info))))
         (parameterize ([check-failures empty])
           (do-while (not (= (section-info-child-count root-info) (section-info-active-child root-info)))
                     (define ran-section : Boolean #f)
                     (define child-counter : Integer 0)
                     (parameterize ([section-table table]
                                    [parent-name root-name]
                                    [parent-ran-child-section ran-section]
                                    [parents-child-counter child-counter])
                       (syntax-parameterize ([section section-impl]
                                             [catch-require catch-require-impl]
                                             [catch-check catch-check-impl])
                         body0
                         body ...)))
           (unless (suppress-output)
             (report-failures))))]))

(module+ test
  (define-syntax (prepend! stx)
    (syntax-parse stx
      [(_ l v) #'(set! l (cons v l))]))

  (define run-order : (Listof Integer) empty)
  (test-case "basic_test"
    (section "a"
             (prepend! run-order 0)
             (section "x"
                      (prepend! run-order 1))
             (section "y"
                      (section "i" (prepend! run-order 2))
                      (section "j" (prepend! run-order 3))
                      (section "k" (prepend! run-order 4))))
    (section "b" (prepend! run-order 5)))
  (define expected '(5 4 0 3 0 2 0 1 0))
  (unless (equal? run-order expected)
    (error "Section logic is broken!" run-order expected)))
\$\endgroup\$
  • \$\begingroup\$ I have looked at this question a few times over the past day or so, and I think one of the reasons I’m a little reluctant to review it is that I don’t completely see the purpose of having this kind of complex control flow. Given that Racket avoids mutation as much as possible, testing different scenarios mostly just involves nesting ordinary let blocks and including assertions within them. I suppose this might be useful if you’re writing tests against a real database or something, though. \$\endgroup\$ – Alexis King Sep 28 '16 at 16:32
  • \$\begingroup\$ @Alexis_King Interesting point. I don't have enough experience yet to know what a functional version should look like, but I think even in a pure functional context something like this is desirable. Imagine you want to check the values of f(g(h(x))) and f(j(h(x))). You basically want two evaluations where the middle function is different. So you would write something like (f ((sections g j) (h x)). You could see this branching in the same way with nested sections. And of course Racket is not Haskell -- mutation is still there and if you do have to use it you probably really want to test it ;) \$\endgroup\$ – Joseph Garvin Sep 28 '16 at 18:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.