make txexpr a match-expander

txexpr/base.rkt

@@ -1,5 +1,9 @@
 #lang racket/base
-(require racket/match sugar/define sugar/list sugar/coerce racket/string racket/list xml)
+(require racket/match sugar/define sugar/list sugar/coerce
+         racket/string racket/list
+         xml
+         "private/define-provide-safe-match.rkt"
+         (for-syntax racket/base syntax/parse))
 (provide cdata? cdata valid-char? xexpr->string xexpr?) ; from xml
 (provide empty) ; from racket/list
 
@@ -124,9 +128,15 @@
     (raise-argument-error func-name "txexpr-elements?" elements))
   (txexpr-unsafe tag attrs elements))
 
-(define+provide+safe (txexpr tag [attrs null] [elements null])
+(define+provide+safe+match (txexpr tag [attrs null] [elements null])
   ((txexpr-tag?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?)
-  (txexpr-base 'txexpr tag attrs elements))
+  (txexpr-base 'txexpr tag attrs elements)
+  #:match-expander
+  (syntax-parser
+    [(_ tag-pat:expr
+        {~optional attrs-pat:expr #:defaults ([attrs-pat #'_])}
+        {~optional elements-pat:expr #:defaults ([elements-pat #'_])})
+     #'(? txexpr? (app txexpr->values tag-pat attrs-pat elements-pat))]))
 
 (define+provide+safe (txexpr* tag [attrs null] . elements)
   ((txexpr-tag?) (txexpr-attrs?) #:rest txexpr-elements? . ->* . txexpr?)

txexpr/private/define-provide-safe-match.rkt

@@ -0,0 +1,76 @@
+#lang racket/base
+
+(provide define+provide+safe+match)
+
+(require racket/match
+         syntax/parse/define
+         (for-syntax racket/base
+                     racket/syntax
+                     syntax/parse
+                     syntax/stx))
+
+;; (define+provide+safe+match name-id
+;;   contract-expr
+;;   value-expr
+;;   #:match-expander
+;;   match-transformer-expr)
+;; 
+;; (define+provide+safe+match (head . args)
+;;   contract-expr
+;;   value-body-expr
+;;   ...+
+;;   #:match-expander
+;;   match-transformer-expr)
+
+(begin-for-syntax
+  ;; Identifier -> [Syntax -> Syntax]
+  (define ((variable-like-transformer id) stx)
+    (cond
+      [(identifier? stx)
+       ; id, but with the source location of stx
+       (datum->syntax id (syntax-e id) stx id)]
+      [(stx-pair? stx)
+       (datum->syntax stx (cons id (stx-cdr stx)) stx stx)])))
+
+(define-syntax-parser define+provide+safe+match
+
+  [(d (head . args)
+      contract:expr
+      value-body:expr ...+
+      #:match-expander match-transformer:expr)
+   #:with fn-expr (syntax/loc this-syntax (λ args value-body ...))
+   (syntax/loc this-syntax
+     (d head contract fn-expr #:match-expander match-transformer))]
+
+  [(_ name:id
+      contract:expr
+      value:expr
+      #:match-expander match-transformer:expr)
+   #:with internal-name (generate-temporary #'name)
+   #:with contract-name (generate-temporary #'name)
+   #:with make-name-match-transformer (generate-temporary #'name)
+   #'(begin
+       (define internal-name (let ([name value]) name))
+
+       (begin-for-syntax
+         (define (make-name-match-transformer name)
+           (with-syntax ([name name]) match-transformer)))
+
+       (define-match-expander name
+         (make-name-match-transformer (quote-syntax internal-name))
+         (variable-like-transformer (quote-syntax internal-name)))
+
+       (provide name)
+
+       (module+ safe
+         (require racket/contract/base)
+
+         (define-module-boundary-contract contract-name internal-name contract
+           #:name-for-blame name)
+
+         (define-match-expander name
+           (make-name-match-transformer (quote-syntax contract-name))
+           (variable-like-transformer (quote-syntax contract-name)))
+
+         (provide name)))])
+

txexpr/test/contract-tests.rkt

@@ -0,0 +1,16 @@
+#lang racket/base
+
+(require (submod "../main.rkt" safe))
+(module+ test
+  (require rackunit))
+
+(module+ test
+  (check-exn (regexp (string-append
+                      "txexpr: contract violation\n"
+                      " *expected: txexpr-tag\\?\n"
+                      " *given: 4\n"
+                      " *in: the 1st argument.*"
+                      " *blaming: .*test/contract-tests.rkt"))
+             (λ () (txexpr 4)))
+  )
+

txexpr/test/tests.rkt

@@ -109,6 +109,19 @@
  (check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) 
                (txexpr->list '(p ((key "value")) "foo")))
 
+ ;; testing the match expander success
+ (check-match '(p ((key "value")) "leaf")
+              (txexpr 'p `((key ,val)) (list "leaf"))
+              (string=? val "value"))
+
+ ;; testing the match expander failure
+ (check-false (match '(p ((key "value")) "something")
+                [(txexpr 'p _ (list "else")) #true]
+                [_                           #false]))
+ (check-false (match "foo"
+                [(txexpr _ _ _) #true]
+                [_              #false]))
+ 
  (check-equal? (get-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p)
  (check-equal? (get-attrs '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value")))
  (check-equal? (get-elements '(p ((key "value"))"foo" "bar" (em "square")))