make txexpr a match-expander (#8 that fixes #7)

.travis.yml

@@ -9,7 +9,7 @@ env:
   global:
     - RACKET_DIR=~/racket
   matrix:
-    - RACKET_VERSION=6.0
+    - RACKET_VERSION=6.0.1
  #   - RACKET_VERSION=6.1
  #   - RACKET_VERSION=6.2
     - RACKET_VERSION=6.3

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,82 @@
+#lang racket/base
+
+(provide define+provide+safe+match)
+
+(require racket/match
+         (for-syntax racket/base
+                     racket/syntax
+                     syntax/parse
+                     syntax/stx
+                     version/utils))
+
+;; (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 define+provide+safe+match
+  (λ (stx)
+    (syntax-parse stx
+
+      [(d (head . args)
+          contract:expr
+          value-body:expr ...+
+          #:match-expander match-transformer:expr)
+       #:with fn-expr (syntax/loc stx (λ args value-body ...))
+       (syntax/loc stx
+         (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)
+       #:with [name-for-blame ...]
+       (cond [(version<=? "6.8" (version)) #'[#:name-for-blame name]]
+             [else                         #'[]])
+
+       #'(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 ...)
+
+             (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

@@ -108,6 +108,19 @@
                (txexpr->list '(p ((key "value")))))
  (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")))