matcher: quasiquote matching.

This allows

  (when-match ^(,a ,b) '(1 2) (list a b)) -> (1 2)

which is a nice alternative that is supported by some
Lisp pattern matchers. We don't need it since we have (@a @b).

The motivation is JSON matching.

  (when-match ^#J{"foo" : {"x" : ~val}}
               #J{"foo" : {"x" : "y"}} val)
  -> "y"

* share/txr/stdlib/match.tl (compile-match): Recognize qquote
case and handle via transform-qquote function.
(non-triv-pat-p): Let's declare quasiquotes to be nontrivial.
(transform-qquote): New function: transform quasi-quoted
syntax into regular pattern matching syntax.

* txr.1: Documented.

1 files changed, 23 insertions, 0 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index fa0ccb80..df143dac 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -616,6 +616,8 @@
          (sys:var (compile-var-match (cadr pat) obj-var var-list))
          (sys:quasi (compile-match (expand-quasi-match (cdr pat) var-list)
                                    obj-var var-list))
+         (sys:qquote (compile-match (transform-qquote (cadr pat))
+                                    obj-var var-list))
          (t (if (non-triv-pat-p pat)
               (compile-cons-structure pat obj-var var-list)
               (compile-atom-match pat obj-var var-list)))))
@@ -844,6 +846,7 @@
     ((@(eq 'sys:expr) (@(bindable) . @nil)) t)
     ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t)
     ((@(eq 'sys:quasi) . @(some @(consp))) t)
+    ((@(eq 'sys:qquote) @nil) t)
     ((@pat . @rest) (or (non-triv-pat-p pat)
                         (non-triv-pat-p rest)))
     (#R(@from @to) (or (non-triv-pat-p from)
@@ -984,6 +987,26 @@
              @(with ,pos 0)
              ,*(quasi-match var-list (normalize args) nil str pos)))))
 
+(defun transform-qquote (syn)
+  (match-case syn
+    ((sys:hash-lit @props . @(coll (@key @val)))
+     (if props
+       (error "~s: only equal hash tables supported" syn)
+       ^@(hash ,*(zip [mapcar transform-qquote key]
+                      [mapcar transform-qquote val]))))
+    ((sys:struct-lit @type . @args)
+     ^@(struct ,(transform-qquote type)
+               ,*[mapcar transform-qquote args]))
+    ((sys:vector-lit @elems)
+     ^#(,*[mapcar transform-qquote elems]))
+    ((json quote @arg) (transform-qquote arg))
+    ((sys:unquote @pat) (if (symbolp pat)
+                          ^(sys:var ,pat)
+                          ^(sys:expr ,pat)))
+    ((@ca . @cd) (cons (transform-qquote ca)
+                       (transform-qquote cd)))
+    (@else else)))
+
 (defun each-match-expander (f pat-seq-list body fun)
   (unless (and (proper-list-p pat-seq-list)
                (evenp (len pat-seq-list)))