Trying to rewrite an ugly macro

Discussion of Common Lisp
Sod Almighty
Posts: 5
Joined: Tue Sep 01, 2015 2:34 pm

Trying to rewrite an ugly macro

Post by Sod Almighty » Tue Sep 01, 2015 3:41 pm

I'm new to lisp, and have been trying to learn Common Lisp by diving in and writing some code. I've read plenty of documentation on the subject, but it's taking a while to really sink in.

I have written a couple of macros (? and ??) for performing unit tests, but I'm having some difficulty. The code is at the end of the post, to avoid cluttering the actual question.

Here is an example of usage:

Code: Select all

(??
  (? "Arithmetic tests"
    (? "Addition"
        (= (+ 1 2) 3)
        (= (+ 1 2 3) 6)
        (= (+ -1 -3) -4))))
And an example of output:

Code: Select all

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

Results: 3 tests passed, 0 tests failed
Now, the existing code works. Unfortunately, the (? ...) macro is ugly, verbose, resistant to change - and I'm pretty sure also badly structured. For example, do I really have to use a list to store pieces of output code and then emit the contents at the end?

I'd like to modify the macro to permit description strings (or symbols) to optionally follow each test, whereupon it would replace the test literal in the output, thus:

Code: Select all

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

Code: Select all

[Arithmetic tests]
  [Addition]
    (PASS) Adding 1 and 2 results in 3
    (PASS) '(= (+ 1 2 3) 6)'
    (PASS) '(= (+ -1 -3) -4)'
But unfortunately I can't find a sensible place in the macro to insert this change. Depending on where I put it, I get errors like you're not inside a backquote expression, label is not defined or body-forms is not defined. I know what these errors mean, but I can't find a way to avoid them.

Also, I'll be wanting to handle exceptions raised in the test, and treat that as a failure. Currently, there is no exception handling code - the test result is merely tested against nil. Again, it is not clear how I should add this functionality.

I'm thinking that maybe this macro is over-complex, due to my inexperience in writing macros; and perhaps if I simplify it, modification will be easier. I don't really want to separate it out into several smaller macros without good reason; but maybe there's a terser way to write it?

Can anyone help me out here, please?

A complete code listing follows:

Code: Select all

(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 "~%"))

David Mullen
Posts: 78
Joined: Mon Dec 01, 2014 12:29 pm
Contact:

Re: Trying to rewrite an ugly macro

Post by David Mullen » Wed Sep 02, 2015 3:44 pm

I write macros in a piecemeal way, separating out parts of the functionality into smaller macros that build on each other, and I like to be able to test each piece separately with MACROEXPAND-1 so I know what I'm getting in the final expansion. This is what keeps me sane, and that's reason enough to do it this way. But my own macrology is what it is, and it probably isn't to everyone's taste.

That being said, part of your problem is that you seem to have misunderstood the theory behind gensyms. The point is to create anonymous symbols to be used in the expansion, so that their bindings won't conflict with any variables introduced by the user of the macro. If you have WITH-GENSYMS inside the backquoted expression then you're defeating the purpose.

With your macro, the first thing I did was to relegate the indentation work to another macro and use a symbol macro to keep track of the indentation level, because the separation made it easier for me to grasp the rest of the code. Secondly, I changed it to use WITH-GENSYMS in the right way. Finally, I added code that looks for an optional description string (or symbol) and pops it off the BODY-FORMS, so the resulting label gets passed to REPORT-RESULT.

Code: Select all

(define-symbol-macro
    ?-indent 0)

(defmacro with-?-indent ((op &optional (indent-string "  ")) &body body)
  (let ((indent-form `(format t "~v@{~A~:*~}" ?-indent ,indent-string)))
    (cond ((eq op :same-level) `(progn ,indent-form ,@body))
          (t (with-gensyms (new-?-indent-value)
               `(progn ,indent-form
                       (let ((,new-?-indent-value (1+ ?-indent)))
                         (symbol-macrolet ((?-indent ,new-?-indent-value))
                           ,@body))))))))

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

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

(defmacro ? (name &body body-forms)
  "Run any number of test forms, optionally nested within further (?) calls, and print the results of each test"
  (when (null body-forms)
    (return-from ? :empty))
  (let ((result '()) label)
    (with-gensyms (test-results single-result)
      `(with-?-indent (:new-level)
         (format-ansi-escaped t "[" :white ,name :normal "]~%")
         (let ((,test-results '()))
           ,(while-pop (body-form body-forms `(progn ,@(nreverse result)))
              (cond ((and (consp body-form) (eq (first body-form) '?))
                     (push `(progn
                              (setf ,test-results (append ,test-results ,body-form))
                              (format t "~%"))
                           result))
                    (t (if (and body-forms (typep (car body-forms) '(or string symbol)))
                           (setf label (pop body-forms))
                           (setf label (format nil "'~a'" body-form)))
                       (push `(with-?-indent (:same-level)
                                (report-start ',label)
                                (let ((,single-result ,body-form))
                                  (format-ansi-escaped t :move-up :start-of-line :clear-line)
                                  (with-?-indent (:same-level)
                                    (report-result ,single-result ',label)
                                    (push ,single-result ,test-results))))
                             result)))))))))

Sod Almighty
Posts: 5
Joined: Tue Sep 01, 2015 2:34 pm

Re: Trying to rewrite an ugly macro

Post by Sod Almighty » Thu Sep 03, 2015 5:44 pm

David Mullen wrote:part of your problem is that you seem to have misunderstood the theory behind gensyms. The point is to create anonymous symbols to be used in the expansion, so that their bindings won't conflict with any variables introduced by the user of the macro. If you have WITH-GENSYMS inside the backquoted expression then you're defeating the purpose.
Yes, I see your point. Thanks for the heads-up.

I'm having a little difficulty understanding your code. For example, I'm unfamilar with symbol macros. Does symbol-macrolet declare a dynamic binding for the ,body call, that shadows the original macro? Why not just use a normal dynamic variable, or a parameter?

Also, why use a keyword symbol for :same-level, rather than a normal symbol?

David Mullen
Posts: 78
Joined: Mon Dec 01, 2014 12:29 pm
Contact:

Re: Trying to rewrite an ugly macro

Post by David Mullen » Fri Sep 04, 2015 12:34 pm

Sod Almighty wrote:Does symbol-macrolet declare a dynamic binding for the ,body call, that shadows the original macro?
No, the shadowing is lexical.
Sod Almighty wrote:Why not just use a normal dynamic variable, or a parameter?
I don't use dynamic variables if I don't need dynamic extent. In this case lexical scoping appeared sufficient, but then I don't know what larger designs you have for the code. Sure, it could be a parameter, but then I'd want to have a separate 'internal' macro to accept the parameter, instead of cramming it into the public-facing macro's lambda list. Furthermore, recall that the lexical environment itself is automatically a parameter to every macro, by way of the macro-expansion function. You just don't have a handle on that environment unless you request it with &ENVIRONMENT in the lambda list.
Sod Almighty wrote:Also, why use a keyword symbol for :same-level, rather than a normal symbol?
It's conventional to use keywords for sets of options that are locally defined and don't need to be extensible from some other package. A complicating factor is that some things are called keywords that aren't in the keyword package—lambda list keywords, for instance, which start with ampersands and are in the CL package. More subtly, there have been debates about when to use keywords vs. packaged symbols, such as for initialization arguments, which by nature are extensible via inheritance. But one straightforward case of using actual keywords would be, say, pprint-indent, which takes a keyword indicating the basis for indentation. The pretty-printing system, by the way, might be adaptable for what you're doing, but I'm not intimate with that aspect of CL.

Sod Almighty
Posts: 5
Joined: Tue Sep 01, 2015 2:34 pm

Re: Trying to rewrite an ugly macro

Post by Sod Almighty » Fri Sep 04, 2015 5:30 pm

David Mullen wrote:
Sod Almighty wrote:Does symbol-macrolet declare a dynamic binding for the ,body call, that shadows the original macro?
No, the shadowing is lexical.
Ah, of course it is! (See, this is how new I am to lisp! I totally forgot it was expanded at compile-time.)

In which case, my question would be "why not just use a normal let binding instead?"

David Mullen
Posts: 78
Joined: Mon Dec 01, 2014 12:29 pm
Contact:

Re: Trying to rewrite an ugly macro

Post by David Mullen » Fri Sep 04, 2015 5:49 pm

Sod Almighty wrote:In which case, my question would be "why not just use a normal let binding instead?"
Well, I guess I had gensyms on the brain, is why. You're right, of course, a normal let binding will also shadow a symbol macro.

Sod Almighty
Posts: 5
Joined: Tue Sep 01, 2015 2:34 pm

Re: Trying to rewrite an ugly macro

Post by Sod Almighty » Sun Sep 06, 2015 1:46 pm

David Mullen wrote:
Sod Almighty wrote:Well, I guess I had gensyms on the brain, is why. You're right, of course, a normal let binding will also shadow a symbol macro.
Forgive my ignorance, but why is a symbol macro necessary in the first place? Isn't it unnecessarily polluting the namespace? What's so great about a symbol macro?

pjstirling
Posts: 166
Joined: Sun Nov 28, 2010 4:21 pm

Re: Trying to rewrite an ugly macro

Post by pjstirling » Mon Sep 07, 2015 10:25 am

In general, they reduce typing, in this particular situation I wouldn't be using them :)

SYMBOL-MACROLET exists primarily for things like WITH-SLOTS, and WITH-ACCESSORS, it allows you lexically to use a symbol to substitute for an expression. e.g. You might implement WITH-SLOTS as:

Code: Select all

(defmacro with-slots ((&rest slot-names) instance &body body)
  `(symbol-macrolet ,(mapcar (lambda (slot-name)
                               `(,slot-name (slot-value ,instance ',slot-name)))
                             slot-names)
     ,@body))
(In general you would capture the "instance" parameter into a LET with a gensym, but I decided that added too much noise) :)

Sod Almighty
Posts: 5
Joined: Tue Sep 01, 2015 2:34 pm

Re: Trying to rewrite an ugly macro

Post by Sod Almighty » Mon Sep 07, 2015 2:36 pm

pjstirling wrote:In general, they reduce typing, in this particular situation I wouldn't be using them :)

SYMBOL-MACROLET exists primarily for things like WITH-SLOTS, and WITH-ACCESSORS, it allows you lexically to use a symbol to substitute for an expression.
So it's a bit like a macro that doesn't need to be the first element in a list?

This doesn't explain why David was using one, however ;)

David Mullen
Posts: 78
Joined: Mon Dec 01, 2014 12:29 pm
Contact:

Re: Trying to rewrite an ugly macro

Post by David Mullen » Tue Sep 08, 2015 10:10 am

Sod Almighty wrote:Forgive my ignorance, but why is a symbol macro necessary in the first place? Isn't it unnecessarily polluting the namespace? What's so great about a symbol macro?
I didn't feel like using a dynamic variable if I didn't need one. Needless to say, a dynamic variable would also add to the namespace, making that particular name globally special. If I tracked the indentation level with a parameter then I'd want to do it through a helper macro or helper function, which necessarily would extend the namespace by some increment. Namespace pollution isn't something that I worry about, because breaking down the system into subroutines that correspond to different phases of processing makes it easer for me to write the code, which, in turn, makes it easier for me to understand my own code a few months later—if and when I need to make changes.

Post Reply