Nesting backquotes
Sunday, May 23, 2004
Psst - want to see some interesting examples of nesting backquotes in CL? David Steuber asked for some on c.l.l. and got three different interesting examples for three different application requirements:
- Defining business rules
- Generating HTML
- Converting Lisp to Java
#1: Coby Beck gave a short example that is in production code:
(defmacro define-business-rule ((name &optional short long) &key field-type formula entities doc) `(progn ,@(mapcar #'(lambda (context) `(set-formula ',(intern (string-upcase name)) ',context ',formula)) entities) ,@(when formula (mapcar #'(lambda (ent) `(merge-fields ,(keywordify ent) ',(list (make-field-syntax `((,name ,short ,long) :type ,(keywordify field-type) :formula ,(expand-formula formula ent) :note ,doc) :derived)))) entities))))It allows him to concisely specify calculated fields in a database application. For example:
(define-business-rule ("ReqProfitMargin" "Required Profit")
:field-type money
:formula ($multiply TenderMarkup TenderTotalCost)
:entities (WorkItem ProjectPart))
and get:
(progn (set-formula 'reqprofitmargin 'workitem '($multiply tendermarkup tendertotalcost)) (set-formula 'reqprofitmargin 'projectpart '($multiply tendermarkup tendertotalcost)) (merge-fields :workitem '((("cReqProfitMargin" "Required Profit") (:money NIL NIL) ($multiply (:projectpart . :tendermarkup) ($if ($eql :projectpartcode "0.00") 0 ($add ($add :estimatedengineeringcost ($add :operationalmargin :corporatemargin)) :onsiteoverheadcost)))))) (merge-fields :projectpart '((("cReqProfitMargin" "Required Profit") (:money NIL NIL) ($multiply (:project . :tendermarkup) :tendertotalcost)))))#2: Wade Humeniuk provided the following example of an HTML defining macro:
(defmacro deftag (tagsym &key element attributes (end-tag t)) (let* ((docstring (format nil "~A: <~S>. The <~S> Tag has the attributes ~{ ~S~}." (or element "Generic Tag") tagsym tagsym attributes)) (tag-macrosym (intern (format nil "<~S>" tagsym))) (endtag-macrosym (intern (format nil "</~S>" tagsym))) (keys (mapcar (lambda (attr) (intern (symbol-name attr) :keyword)) attributes)) (tag-arglist (mapcar (lambda (attr) (list attr nil)) attributes))) `(progn (defmacro ,tag-macrosym (&key ,@tag-arglist (stream '*primitive-html-stream*)) ,docstring (let ((non-nil-attributes (loop for attribute in (list ,@attributes) for attrsym in '(,@keys) when attribute collect attrsym and collect attribute))) `(write-tag ',',tagsym ,stream ,@non-nil-attributes))) (export ',tag-macrosym) (unless (eq ,end-tag :forbidden) (defmacro ,endtag-macrosym (&key (stream '*primitive-html-stream*)) `(write-end-tag ',',tagsym ,stream)) (export ',endtag-macrosym)))))For example, to use this macro to create the HTML <b> tag you code the following:
(deftag b
:element "Bold Text"
:attributes #.*%attrs*)
#3: Antonio Menezes Leitao created
this beauty for the
Linj ("Lisp in Java" or "Linj is not Java") language (commentary below is his):
(defmacro def-swing-constructor (class-superclass (&rest setters) &body body) (multiple-value-bind (class superclass) (if (consp class-superclass) (values-list class-superclass) (values class-superclass nil)) (let ((all-slots (append setters (gethash superclass *swing-constructors* (list))))) (setf (gethash class *swing-constructors*) all-slots) `(defmacro ,class (&key ,@(mapcar #'(lambda (setter) `(,setter nil ,(conc-symbol setter '-p))) all-slots)) `(let ((,',class (new ',',class))) ,@,@(mapcar #'(lambda (setter) `(when ,(conc-symbol setter '-p) `((send ,',class ,',(conc-symbol 'set- setter) ,,setter)))) all-slots) ,@'(,@body) (setf the-component ,',class))))))To use this, you write something like:
(def-swing-constructor test ;;a class name (a ;;their 'initialization' args b) (foo) ;;further initialization (bar))and it expands into:
(defmacro test (&key (a () a-p) (b () b-p)) `(let ((test (new 'test))) ,@(when a-p `((send test set-a ,a))) ,@(when b-p `((send test set-b ,b))) (foo) (bar) (setf the-component test)))The idea is that it allows you to replace the initialization of instances that require setters with initialization using initargs. For those who don't know Swing (the Java library for graphical interfaces), it's enough to say that there are so many configuration options in the library classes that they just couldn't put then as constructor parameters (because they don't have keyword parameters in Java). The result is that they use setters to define those options. Unfortunately, this makes the construction of Swing graphical interfaces a real PITA. You just can't write functional code because everything is done via setters.
Using Linj, of course, you have other solutions. The above little macro is just an experiment I'm doing that allows me to "convert" setters into initargs. I'll show just the definition for the JLabel class:
(def-swing-constructor (j-label j-component)
(text
icon
horizontal-alignment
vertical-alignment
disabled-icon
displayed-mnemonic
horizontal-text-position
vertical-text-position
icon-text-gap
label-for))(def-swing-constructor component
(component-orientation
cursor
drop-target
locale
location
name
size))
The j-label definition then composes the initargs for its class hierarchy
and expands into:
(defmacro j-label (&key (text () text-p) (icon () icon-p) (horizontal-alignment () horizontal-alignment-p) (vertical-alignment () vertical-alignment-p) (disabled-icon () disabled-icon-p) (displayed-mnemonic () displayed-mnemonic-p) (horizontal-text-position () horizontal-text-position-p) (vertical-text-position () vertical-text-position-p) (icon-text-gap () icon-text-gap-p) (label-for () label-for-p) (action-map () action-map-p) (alignment-x () alignment-x-p) (alignment-y () alignment-y-p) (autoscrolls () autoscrolls-p) (background () background-p) (border () border-p) (debug-graphics-options () debug-graphics-options-p) (double-buffered () double-buffered-p) (enabled () enabled-p) (font () font-p) (foreground () foreground-p) (input-verifier () input-verifier-p) (maximum-size () maximum-size-p) (minimum-size () minimum-size-p) (next-focusable-component () next-focusable-component-p) (opaque () opaque-p) (preferred-size () preferred-size-p) (request-focus-enabled () request-focus-enabled-p) (tool-tip-text () tool-tip-text-p) (u-i () u-i-p) (verify-input-when-focus-target () verify-input-when-focus-target-p) (visible () visible-p) (layout () layout-p) (bounds () bounds-p) (component-orientation () component-orientation-p) (cursor () cursor-p) (drop-target () drop-target-p) (locale () locale-p) (location () location-p) (name () name-p) (size () size-p)) `(let ((j-label (new 'j-label))) ,@(when text-p `((send j-label set-text ,text))) ,@(when icon-p `((send j-label set-icon ,icon))) ,@(when horizontal-alignment-p `((send j-label set-horizontal-alignment ,horizontal-alignment))) ,@(when vertical-alignment-p `((send j-label set-vertical-alignment ,vertical-alignment))) ,@(when disabled-icon-p `((send j-label set-disabled-icon ,disabled-icon))) ,@(when displayed-mnemonic-p `((send j-label set-displayed-mnemonic ,displayed-mnemonic))) ,@(when horizontal-text-position-p `((send j-label set-horizontal-text-position ,horizontal-text-position))) ,@(when vertical-text-position-p `((send j-label set-vertical-text-position ,vertical-text-position))) ,@(when icon-text-gap-p `((send j-label set-icon-text-gap ,icon-text-gap))) ,@(when label-for-p `((send j-label set-label-for ,label-for))) ,@(when action-map-p `((send j-label set-action-map ,action-map))) ,@(when alignment-x-p `((send j-label set-alignment-x ,alignment-x))) ,@(when alignment-y-p `((send j-label set-alignment-y ,alignment-y))) ,@(when autoscrolls-p `((send j-label set-autoscrolls ,autoscrolls))) ,@(when background-p `((send j-label set-background ,background))) ,@(when border-p `((send j-label set-border ,border))) ,@(when debug-graphics-options-p `((send j-label set-debug-graphics-options ,debug-graphics-options))) ,@(when double-buffered-p `((send j-label set-double-buffered ,double-buffered))) ,@(when enabled-p `((send j-label set-enabled ,enabled))) ,@(when font-p `((send j-label set-font ,font))) ,@(when foreground-p `((send j-label set-foreground ,foreground))) ,@(when input-verifier-p `((send j-label set-input-verifier ,input-verifier))) ,@(when maximum-size-p `((send j-label set-maximum-size ,maximum-size))) ,@(when minimum-size-p `((send j-label set-minimum-size ,minimum-size))) ,@(when next-focusable-component-p `((send j-label set-next-focusable-component ,next-focusable-component))) ,@(when opaque-p `((send j-label set-opaque ,opaque))) ,@(when preferred-size-p `((send j-label set-preferred-size ,preferred-size))) ,@(when request-focus-enabled-p `((send j-label set-request-focus-enabled ,request-focus-enabled))) ,@(when tool-tip-text-p `((send j-label set-tool-tip-text ,tool-tip-text))) ,@(when u-i-p `((send j-label set-u-i ,u-i))) ,@(when verify-input-when-focus-target-p `((send j-label set-verify-input-when-focus-target ,verify-input-when-focus-target))) ,@(when visible-p `((send j-label set-visible ,visible))) ,@(when layout-p `((send j-label set-layout ,layout))) ,@(when bounds-p `((send j-label set-bounds ,bounds))) ,@(when component-orientation-p `((send j-label set-component-orientation ,component-orientation))) ,@(when cursor-p `((send j-label set-cursor ,cursor))) ,@(when drop-target-p `((send j-label set-drop-target ,drop-target))) ,@(when locale-p `((send j-label set-locale ,locale))) ,@(when location-p `((send j-label set-location ,location))) ,@(when name-p `((send j-label set-name ,name))) ,@(when size-p `((send j-label set-size ,size))) (setf the-component j-label)))And now, in the appropriate context, you can write:
(label :text "Hi" :name "my-label" :border 2 :opaque nil)and you get:
(let ((label (new 'j-label))) (send label set-text "hi") (send label set-border 2) (send label set-opaque nil) (send label set-name "my-label") (setf the-component label))Linj then translates this into the following Java code fragment:
JLabel label = new JLabel()
label.setText("hi")
label.setBorder(2)
label.setOpaque(false)
label.setName("my-label")
theComponent = label
Things become more interesting when you combine this with layout constructors. Here is one example:
(table ()
(tr (td (j-label :title "Foo")) (td (j-text-field) :colspan 5))
...)
This hugely simplies the construction of Swing interfaces.
