Macros 试图重写一个丑陋的宏

我是lisp新手，一直试图通过潜入和编写一些代码来学习常见的lisp。我已经阅读了大量关于这个主题的文档，但要真正理解它还需要一段时间

我已经编写了两个宏（

？

和

？

）来执行单元测试，但是我遇到了一些困难。代码在文章的末尾，以避免把实际问题弄乱

下面是一个用法示例：

(??
  (? "Arithmetic tests"
    (? "Addition"
        (= (+ 1 2) 3)
        (= (+ 1 2 3) 6)
        (= (+ -1 -3) -4))))

以及一个输出示例：

[Arithmetic tests]
  [Addition]
    (PASS) '(= (+ 1 2) 3)'
    (PASS) '(= (+ 1 2 3) 6)'
    (PASS) '(= (+ -1 -3) -4)'

Results: 3 tests passed, 0 tests failed

现在，现有的代码可以工作了。不幸的是，

（？…）

宏丑陋、冗长，难以更改，而且我很确定它的结构也很糟糕。例如，我真的必须使用列表来存储输出代码片段，然后在最后发出内容吗

我想修改宏以允许描述字符串（或符号）选择性地跟随每个测试，从而替换输出中的测试文字，因此：

(??
  (? "Arithmetic tests"
    (? "Addition"
        (= (+ 1 2) 3)    "Adding 1 and 2 results in 3"
        (= (+ 1 2 3) 6)
        (= (+ -1 -3) -4))))

输出：

[Arithmetic tests]
  [Addition]
    (PASS) Adding 1 and 2 results in 3
    (PASS) '(= (+ 1 2 3) 6)'
    (PASS) '(= (+ -1 -3) -4)'

但不幸的是，我无法在宏中找到一个合理的位置来插入此更改。根据我把它放在哪里，我会得到一些错误，如

您不在反引号表达式中

，

标签未定义

或

主体形式未定义

。我知道这些错误的意思，但我找不到避免它们的方法

另外，我希望在测试中处理异常，并将其视为失败。目前，没有异常处理代码-测试结果仅针对nil进行测试。同样，我不清楚应该如何添加此功能

我想也许这个宏太复杂了，因为我没有编写宏的经验；如果我简化它，修改会更容易。我真的不想毫无理由地把它分成几个较小的宏；但也许有更简洁的方式来写

有人能帮我吗

完整的代码清单如下：

(defmacro with-gensyms ((&rest names) &body body)
    `(let ,(loop for n in names collect `(,n (gensym)))
         ,@body))

(defmacro while (condition &body body)
    `(loop while ,condition do (progn ,@body)))

(defun flatten (L)
  "Converts a list to single level."
  (if (null L)
    nil
    (if (atom (first L))
      (cons (first L) (flatten (rest L)))
      (append (flatten (first L)) (flatten (rest L))))))

(defun starts-with-p (str1 str2)
  "Determine whether `str1` starts with `str2`"
  (let ((p (search str2 str1)))
    (and p (= 0 p))))

(defmacro pop-first-char (string)
    `(with-gensyms (c)
        (if (> (length ,string) 0)
            (progn
                (setf c (schar ,string 0))
                (if (> (length ,string) 1)
                    (setf ,string (subseq ,string 1))
                    (setf ,string ""))))
    c))

(defmacro pop-chars (string count)
    `(with-gensyms (result)
        (setf result ())
        (dotimes (index ,count)
            (push (pop-first-char ,string) result))
        result))

(defun format-ansi-codes (text)
    (let ((result ()))
        (while (> (length text) 0)
            (cond
                ((starts-with-p text "\\e")
                    (push (code-char #o33) result)
                    (pop-chars text 2)
                )
                ((starts-with-p text "\\r")
                    (push (code-char 13) result)
                    (pop-chars text 2)
                )
                (t (push (pop-first-char text) result))
        ))
        (setf result (nreverse result))
        (coerce result 'string)))

(defun kv-lookup (values key)
    "Like getf, but works with 'keys as well as :keys, in both the list and the supplied key"
    (setf key (if (typep key 'cons) (nth 1 key) key))
    (while values
        (let ((k (pop values)) (v (pop values)))
            (setf k (if (typep k 'cons) (nth 1 k) k))
            (if (eql (symbol-name key) (symbol-name k))
                (return v)))))

(defun make-ansi-escape (ansi-name)
    (let ((ansi-codes '( :normal "\\e[00m" :white "\\e[1;37m" :light-grey "\\e[0;37m" :dark-grey "\\e[1;30m"
                                    :red "\\e[0;31m" :light-red "\\e[1;31m" :green "\\e[0;32m" :blue "\\e[1;34m" :dark-blue "\\e[1;34m"
                                    :cyan "\\e[1;36m" :magenta "\\e[1;35m" :yellow "\\e[0;33m"
                                    :bg-dark-grey "\\e[100m"
                                    :bold "\\e[1m" :underline "\\e[4m"
                                    :start-of-line "\\r" :clear-line "\\e[2K" :move-up "\\e[1A")))
    (format-ansi-codes (kv-lookup ansi-codes ansi-name))
    ))

(defun format-ansi-escaped-arg (out-stream arg)
    (cond
        ((typep arg 'symbol) (format out-stream "~a" (make-ansi-escape arg)))
        ((typep arg 'string) (format out-stream arg))
        (t (format out-stream "~a" arg))
    ))

(defun format-ansi-escaped (out-stream &rest args)
    (while args
        (let ((arg (pop args)))
            (if (typep arg 'list)
                (let ((first-arg (eval (first arg))))
                    (format out-stream first-arg (second arg))
                )
                (format-ansi-escaped-arg out-stream arg)
        ))
    ))

(defmacro while-pop ((var sequence &optional result-form) &rest forms)
    (with-gensyms (seq)
        `(let (,var)
            (progn
                (do () ((not ,sequence))
                    (setf ,var (pop ,sequence))
                    (progn ,@forms))
                ,result-form))))

(defun report-start (form)
    (format t "(    ) '~a'~%" form))

(defun report-result (result form)
        (format-ansi-escaped t "(" (if result :green :red) `("~:[FAIL~;PASS~]" ,result) :normal `(") '~a'~%" ,form))
        result)

(defmacro ? (name &body body-forms)
    "Run any number of test forms, optionally nested within further (?) calls, and print the results of each test"
    (with-gensyms (result indent indent-string)
        (if (not body-forms)
            :empty
            (progn
                (setf result () indent 0 indent-string "  ")
                (cond
                    ((typep (first body-forms) 'integer)
                        (setf indent (pop body-forms))))
                `(progn
                    (format t "~v@{~A~:*~}" ,indent ,indent-string)
                    (format-ansi-escaped t "[" :white ,name :normal "]~%")
                    (with-gensyms (test-results)
                        (setf test-results ())
                        ,(while-pop (body-form body-forms `(progn ,@(nreverse result)))
                            (cond
                                ( (EQL (first body-form) '?)
                                    (push `(progn
                                        (setf test-results (append test-results (? ',(nth 1 body-form) ,(1+ indent) ,@(nthcdr 2 body-form))))
                                        (format t "~%")
                                        test-results
                                    ) result)
                                )
                                (t
                                    (push `(progn
                                        (format t "~v@{~A~:*~}" ,(1+ indent) ,indent-string)
                                        (report-start ',body-form)
                                        (with-gensyms (result label)
                                            (setf result ,body-form)
                                            (format-ansi-escaped t :move-up :start-of-line :clear-line)
                                            (format t "~v@{~A~:*~}" ,(1+ indent) ,indent-string)
                                            (push (report-result result ',body-form) test-results)
                                            test-results
                                    )) result))))))))))

(defun ?? (&rest results)
    "Run any number of tests, and print a summary afterward"
    (setf results (flatten results))
    (format-ansi-escaped t "~&" :white "Results: " :green `("~a test~:p passed" ,(count t results)) :normal ", "
        (if (find NIL results) :red :normal) `("~a test~:p failed" ,(count NIL results))
        :yellow `("~[~:;, ~:*~a test~:p not run~]" ,(count :skip results))
        :brown `("~[~:;, ~:*~a empty test group~:p skipped~]" ,(count :empty results))
        :normal "~%"))

---

就我而言，

？

宏相当技术性，很难遵循格式化函数背后的逻辑。因此，与其跟踪错误，我想建议我自己尝试一下，也许它会有用

我认为实际上您的

？

不希望评估任何内容，而是将其主体视为单独的测试或部分。如果正文包含一个以

？

开头的列表，则该列表表示一个节；其他元素是测试表单，可选地后跟描述。所以在我的实现中，

？

将是一个宏，

？

将只是一个符号

我从一厢情愿开始。我假设我可以使用函数

make test item

创建单独的测试，并使用函数

make test section

创建测试部分（它们的实现现在并不重要），我可以使用辅助函数

display test

显示测试，并使用函数

results

计算结果，它返回两个值：测试总数和通过的测试数。那我要密码

(??
  (? "Arithmetic tests"
     (? "Addition"
        (= (+ 1 2) 3) "Adding 1 and 2 results in 3"
        (= (+ 1 2 3) 6)
        (= (+ -1 -3) 4))
     (? "Subtraction"
        (= (- 1 2) 1)))
  (= (sin 0) 0) "Sine of 0 equals 0")

扩展成

(let ((tests (list (make-test-section :header "Arithmetic tests"
                                      :items (list (make-test-section :header "Addition"
                                                                      :items (list (make-test-item :form '(= (+ 1 2) 3)
                                                                                                   :description "Adding 1 and 2 results in 3"
                                                                                                   :passp (= (+ 1 2) 3))
                                                                                   (make-test-item :form '(= (+ 1 2 3) 6)
                                                                                                   :passp (= (+ 1 2 3) 6))
                                                                                   (make-test-item :form '(= (+ -1 -3) 4)
                                                                                                   :passp (= (+ -1 -3) 4))))
                                                   (make-test-section :header "Subtraction"
                                                                      :items (list (make-test-item :form '(= (- 1 2) 1)
                                                                                                   :passp (= (- 1 2) 1))))))
                   (make-test-item :form '(= (sin 0) 0)
                                   :passp (= (sin 0) 0)
                                   :description "Sine of 0 equals 0"))))
  (loop for test in tests
        with total = 0
        with passed = 0
        do (display-test test 0 t)
        do (multiple-value-bind (ttl p) (results test)
             (incf total ttl)
             (incf passed p))
        finally (display-result total passed t)))

这里创建了一个测试列表；然后我们遍历它，打印每个测试（0表示缩进的零级，

t

与

格式

相同），并跟踪结果，最后显示总结果。我认为这里不需要显式的

eval

它可能不是有史以来最精致的一段代码，但它似乎是可管理的。我在下面提供了缺少的定义，它们非常琐碎（可以改进），与宏无关

现在我们转到宏。将两段代码视为数据，然后我们需要一个列表处理函数，将第一个函数转换成第二个。一些辅助功能将派上用场

主要任务是解析

？

的主体，并生成要进入

let

的测试列表

(defun test-item-form (form description)
  `(make-test-item :form ',form :description ,description :passp ,form))

(defun test-section-form (header items)
  `(make-test-section :header ,header :items (list ,@items)))

(defun parse-test (forms)
  (let (new-forms)
    (loop
      (when (null forms)
        (return (nreverse new-forms)))
      (let ((f (pop forms)))
        (cond ((and (listp f) (eq (first f) '?))
               (push (test-section-form (second f) (parse-test (nthcdr 2 f))) new-forms))
              ((stringp (first forms))
               (push (test-item-form f (pop forms)) new-forms))
              (t (push (test-item-form f nil) new-forms)))))))

这里的

parse test

基本上吸收了

？

的语法。每个迭代使用一个或两个表单，并收集相应的

make-…

表单。这些函数可以在REPL中轻松测试（当然，我在编写时也测试过）

现在宏变得非常简单：

(defmacro ?? (&body body)
  `(let ((tests (list ,@(parse-test body))))
     (loop for test in tests
           with total = 0
           with passed = 0
           do (display-test test 0 t)
           do (multiple-value-bind (ttl p) (results test)
                (incf total ttl)
                (incf passed p))
           finally (display-result total passed t))))

它捕获变量名称空间和函数1中的一些符号（扩展可能包含

生成测试项

和

生成测试部分

）。使用gensyms的干净解决方案会很麻烦，因此我建议将所有定义移动到一个单独的包中，只导出

？

和

？

为了完整起见，这里是测试API的一个实现。事实上，这就是我开始编码的地方，直到我确保大的

let

-表单工作；然后我转到宏部分。这个实现相当草率；特别是，它不支持终端颜色，

display test

甚至不能将节输出到字符串中

(defstruct test-item form description passp)

(defstruct test-section header items)

(defun results (test)
  (etypecase test
    (test-item (if (test-item-passp test)
                   (values 1 1)
                   (values 1 0)))
    (test-section (let ((items-count 0)
                        (passed-count 0))
                    (dolist (i (test-section-items test) (values items-count passed-count))
                      (multiple-value-bind (i p) (results i)
                        (incf items-count i)
                        (incf passed-count p)))))))

(defparameter *test-indent* 2)

(defun display-test-item (i level stream)
  (format stream "~V,0T~:[(FAIL)~;(PASS)~] ~:['~S'~;~:*~A~]~%"
          (* level *test-indent*)
          (test-item-passp i)
          (test-item-description i)
          (test-item-form i)))

(defun display-test-section-header (s level stream)
  (format stream "~V,0T[~A]~%"
          (* level *test-indent*)
          (test-section-header s)))

(defun display-test (test level stream)
  (etypecase test
    (test-item (display-test-item test level stream))
    (test-section
      (display-test-section-header test level stream)
      (dolist (i (test-section-items test))
        (display-test i (1+ level) stream)))))

(defun display-result (total passed stream)
  (format stream "Results: ~D test~:P passed, ~D test~:P failed.~%" passed (- total passed)))

---

所有代码都是在WTFPL下获得许可的。

考虑使用一个已经存在的测试库，例如or。可能是代码审查堆栈交换的候选。从外观上看，是的，欢迎随时来询问。请看Peter Seibel实用公共Lisp（）@TerjeD的第9章（实用：构建单元测试框架）。我已经看过了，谢谢。事实上，正是这一点促使我尝试写一篇。谢谢你非常详细的回答。不过我在理解上有点困难。我看不到（结果）函数的定义；我有点不确定如何正确打印测试标题。似乎我有点不知所措：（我现在已经找到了（结果）函数；）。。。然而，我需要一些时间才能完全理解这一切。我会把头撞上一会儿，看看会发生什么。