Mixed case tag names in cl-who

Question

I'm using cl-who to generate svg, and it is working fine up until I need a mixed case tag:

(with-html-output (*standard-output*)
  (:defs
    (:|radialGradient| :id "grad1" :cy "20" :fx "10%" :fy "50%" :r "8"
      (:stop :offset "0%" :stop-color "#fff")
      (:stop :offset "100%" :stop-color "#000"))))

There is a variable, *downcase-tokens-p*, for situations like this. It's a bit hard to work with:

(let ((*downcase-tokens-p* nil))
  (with-html-output (*standard-output*)
    (:defs
        (:|radialGradient| :id "grad1" :cy "20" :fx "10%" :fy "50%" :r "8"))))

Output:

<defs>
  <radialgradient id='grad1' cy='20' fx='10%' fy='50%' r='8'>
  </radialgradient>
</defs>

Wrapping with let has no effect because *downcase-tokens-p* was evidently set T at macro expansion time.

So we need to haul out eval:

(let ((*downcase-tokens-p* nil))
  (eval
  '(with-html-output (*standard-output*)
    (:defs
      (:|radialGradient| :id "grad1" :cy "20" :fx "10%" :fy "50%" :r "8")))))

Output:

<DEFS>
  <radialGradient ID='grad1' CY='20' FX='10%' FY='50%' R='8'>
  </radialGradient>
</DEFS>

This works for the radialGradient tag, but now I'll need to || wrap everything else.

What is the simplest way to get the radialGradient tag to display properly while leaving everything else alone?

Edit: examples added.

Answer 1

As of cl-who-20190710-git it preserves mixed-case keywords as tagnames by default, so they can be used without adding any macros/methods:

 (htm 
   (:|clipPath| :x 0 :y 0 ...))

There is *downcase-tokens-p* option to configure it.

Answer 2

You could change the Lisp reader's case.

PRESERVE

(setf (readtable-case *readtable*) :preserve)

From now on, all CL symbols must be written in uppercase, but you could make the changes localized using named-readtables only in files where you need to read SVG trees.

(DEFPACKAGE :TWHO (:USE :CL :CL-WHO))
(IN-PACKAGE :TWHO)

(SETF *DOWNCASE-TOKENS-P* NIL)

(WITH-HTML-OUTPUT (*STANDARD-OUTPUT* *STANDARD-OUTPUT* :INDENT T)
  (:defs
    (:radialGradient :id "grad1" :cy "20" :fx "10%" :fy "50%" :r "8"
      (:stop :offset "0%" :stop-color "#fff")
      (:stop :offset "100%" :stop-color "#000"))))

Writes the following:

<defs>
  <radialGradient id='grad1' cy='20' fx='10%' fy='50%' r='8'>
    <stop offset='0%' stop-color='#fff'></stop>
    <stop offset='100%' stop-color='#000'></stop>
  </radialGradient>
</defs>

INVERT

I'd personally use :invert, but in that case you have to write all the lowercase SVG symbols in uppercase.

(SETF (READTABLE-CASE *READTABLE*) :INVERT)

(with-html-output (*standard-output* *standard-output* :indent t)
  (:DEFS
    (:radialGradient :ID "grad1" :CY "20" :FX "10%" :FY "50%" :R "8"
      (:STOP :OFFSET "0%" :STOP-COLOR "#fff")
      (:STOP :OFFSET "100%" :STOP-COLOR "#000"))))

Writes the same thing:

<defs>
  <radialGradient id='grad1' cy='20' fx='10%' fy='50%' r='8'>
    <stop offset='0%' stop-color='#fff'></stop>
    <stop offset='100%' stop-color='#000'></stop>
  </radialGradient>
</defs>"

But at least you the CL code does not need to be written in uppercase.

Macros and/or macro characters

You can make your changes local with macros and macro characters.

Reset everything to their default values:

(setf *downcase-tokens-p* t)
(setf (readtable-case *readtable*) :upcase)

I would personally not mind changing *downcase-tokens-p* globally, but if you really want to, another approach besides using eval is to macroexpand manually. For this example I am using macroexpand-dammit:

(ql:quickload "macroexpand-dammit")

Then, you define a custom macro:

(defmacro with-svg-output ((stream) &body body)
  (let ((*downcase-tokens-p* nil))
    (let ((stream% (copy-symbol :stream)))
      (macroexpand-dammit:macroexpand-dammit 
       `(let ((,stream% ,stream))
          (with-html-output (,stream% ,stream% :indent t)
            ,@body))))))

Finally, to change the readtable's case only when reading SVG forms, define a custom reader function; I bind it to the #@ character sequence:

(set-dispatch-macro-character
 #\# #\@
 (lambda (stream &rest args)
   (declare (ignore args))
   (let ((*readtable* (copy-readtable)))
     (setf (readtable-case *readtable*) :invert)
     (read stream t nil t))))

The example can be rewritten as:

(with-svg-output (*standard-output*)
  #@(:DEFS
      (:radialGradient :ID "grad1" :CY "20" :FX "10%" :FY "50%" :R "8"
        (:STOP :OFFSET "0%" :STOP-COLOR "#fff")
        (:STOP :OFFSET "100%" :STOP-COLOR "#000"))))

The advantage here is that your changes are only applied locally and that there is a very distinctive syntax which signals that there is something different happening. If you are ok with writing code in uppercase inside the SVG expression, then you can use :preserve instead. It depends on what is more convenient for you.

Answer 3

Here's a generic solution:

(defmethod convert-tag-to-string-list :around ((tag t) attr-list body body-fn)
  (if (find-if #'lower-case-p (symbol-name tag))
      (nconc (list* "<"
                    (symbol-name tag)
                    (convert-attributes attr-list))
             (list ">")
             (funcall body-fn body)
             (list (format nil "</~a>" (symbol-name tag))))
      (call-next-method)))

Results:

CL-USER> (with-html-output (*standard-output*)
           (:asdf
            (:ASDF
             (:|aSDf|
               (:|ASDF|)))))
<asdf><asdf><aSDf><asdf></asdf></aSDf></asdf></asdf>

Answer 4

Overriding the rendering method for individual tags:

(defmethod convert-tag-to-string-list ((tag (eql :radialgradient))
                                       attr-list body body-fn)
  (nconc (cons "<radialGradient"
               (convert-attributes attr-list))
         (list ">")
         (funcall body-fn body)
         (list "</radialGradient>")))

With |'s removed:

(with-html-output (*standard-output*)
  (:defs
      (:radialGradient :id "grad1" :cy "20" :fx "10%" :fy "50%" :r "8")))

Output:

<defs>
  <radialGradient id='grad1' cy='20' fx='10%' fy='50%' r='8'
  </radialGradient>
</defs>

A convert-tag-to-string-list method will need to be defined for every mixed case SVG tag that is in use.