test-error* added by r1b on Sat Jul 6 02:19:13 2019


  ; Based on the commented-out `test-error*` in the `test` egg

  (define-syntax test-error*
    (syntax-rules ()
      ((_ ?msg (?kind (?properties ...)) ?expr)
       (let ((get-error-info
               (lambda (exn properties)
                 (let ((kind (if (= (length (##sys#slot exn 1)) 1)
                                 (car (##sys#slot exn 1))
                                 (##sys#slot exn 1))))
                   (list kind
                         (flatten (map (lambda (l)
                                         (let ((property (car l)))
                                           (list property
                                                 (get-condition-property exn
                                                                         kind
                                                                         property))))
                                       (chop properties 2))))))))
         (let-syntax ((error-info:
                        (syntax-rules ()
                          ((_ ?expr)
                           (condition-case (begin ?expr "<no error thrown>")
                             (exn () (get-error-info exn '(?properties ...))))))))

           (test ?msg '(?kind (?properties ...)) (error-info: ?expr)))))
      ((_ ?msg ?kind ?expr)
       (test-error* ?msg (?kind ()) ?expr))
      ((_ (?kind (?properties ...)) ?expr)
       (let ((render-properties
               (lambda (properties)
                 (string-intersperse (map (lambda (l)
                                            (let ((property (car l))
                                                  (value (cadr l)))
                                              (sprintf "~A=~A" property value)))
                                          (chop properties 2))
                                     ", ")))))
       (test-error* (sprintf "raises ~S with ~A" '?kind (render-properties '(?properties ...)))
                    (?kind (?properties ...))
                    ?expr))
      ((_ ?kind ?expr)
       (test-error* (sprintf "raises ~S" '?kind)
                    (?kind ())
                    ?expr))))