From 2b08c608d1a349ac94a6d38c34331fdbf61450a7 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sun, 31 Jan 2016 22:41:44 -0800
Subject: [PATCH] use syntax-parse for `define-tag-function`

---
 info.rkt               |  2 +-
 pollen/private/ts.rktd |  2 +-
 pollen/tag.rkt         | 25 +++++++++++++------------
 3 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/info.rkt b/info.rkt
index 13681d3..52cb92c 100644
--- a/info.rkt
+++ b/info.rkt
@@ -1,7 +1,7 @@
 #lang info
 (define collection 'multi)
 
-(define version "0.9.913.41357")
+(define version "0.9.913.85304")
 (define deps '("base" "txexpr" "sugar" ("markdown" #:version "0.18") "htdp"
                "at-exp-lib" "html-lib" "rackjure" "web-server-lib" "scribble-text-lib" "rackunit-lib"
                "gui-lib"))
diff --git a/pollen/private/ts.rktd b/pollen/private/ts.rktd
index 23972a4..a11dd10 100644
--- a/pollen/private/ts.rktd
+++ b/pollen/private/ts.rktd
@@ -1 +1 @@
-1454264957
+1454308904
diff --git a/pollen/tag.rkt b/pollen/tag.rkt
index 16bb46e..996b17f 100644
--- a/pollen/tag.rkt
+++ b/pollen/tag.rkt
@@ -1,5 +1,5 @@
 #lang pollen/mode racket/base
-(require (for-syntax racket/base))
+(require (for-syntax racket/base syntax/parse))
 (require txexpr racket/string racket/match)
 (provide default-tag-function make-default-tag-function define-tag-function)
 
@@ -66,34 +66,35 @@
 
 
 (define-syntax (define-tag-function stx)
-  (syntax-case stx (λ)
-    [(_ (ID ARG ...) EXPR ...)
+  (syntax-parse stx
+    #:literals (λ)
+    [(_ (ID:id ARG:id ...) EXPR:expr ...)
      #'(define-tag-function ID (λ (ARG ...) EXPR ...))]
-    [(_ ID (λ (ATTRS ELEMS) EXPR0 EXPR ...))
+    [(_ ID:id (λ (ATTRS:id ELEMS:id ARG:id ...) EXPR:expr ...))
+     #:fail-when (> (length (syntax->list #'(ARG ...))) 0) "tag function must have exactly 2 positional arguments"
+     #:fail-when (check-duplicate-identifier (list #'ATTRS #'ELEMS)) "duplicate variable name"
+     #:fail-when (null? (syntax->list #'(EXPR ...))) "body of definition cannot be empty"
      #'(define ID
          (make-keyword-procedure
           (λ (kws kwargs . args)
             (define tx-proc (keyword-apply default-tag-function kws kwargs (list 'ID)))
             (define tx (apply tx-proc args))
             (define-values (_ ATTRS ELEMS) (txexpr->values tx))
-            EXPR0 EXPR ...)))]
-    [(_ ID (λ (ATTRS ELEMS)))
-     (raise-syntax-error 'define-tag-function (format "bad syntax (no expressions for procedure body) in ~a" (syntax->datum stx)))]
-    [(_ ID (λ (ARG ...) EXPR ...)) (raise-syntax-error 'define-tag-function (format "bad syntax (arity must be exactly 2 positional arguments) in ~a" (cadr (syntax->datum stx))))]))
+            EXPR ...)))]))
 
 
 (module+ test
   (require rackunit)
-   (define foo2 (default-tag-function 'foo))
+  (define foo2 (default-tag-function 'foo))
   
   (define-tag-function (foo attrs elems)
     `(foo ,(reverse attrs) ,@elems))
   (check-txexprs-equal? ◊foo[#:zim "zam"]{hello}  ◊foo2[#:zim "zam"]{hello})
   (check-txexprs-equal? ◊foo[#:ding "dong" '((zim "zam"))]{hello}  ◊foo2[#:ding "dong" '((zim "zam"))]{hello})
   (check-txexprs-equal? ◊foo['zim: "zam" #:ding "dong" ]{hello} ◊foo2['zim: "zam" #:ding "dong" ]{hello})
-
- (define-tag-function foolam (λ (attrs elems)
-    `(foo ,(reverse attrs) ,@elems)))
+  
+  (define-tag-function foolam (λ (attrs elems)
+                                `(foo ,(reverse attrs) ,@elems)))
   (check-txexprs-equal? ◊foolam[#:zim "zam"]{hello}  ◊foo2[#:zim "zam"]{hello})
   (check-txexprs-equal? ◊foolam[#:ding "dong" '((zim "zam"))]{hello}  ◊foo2[#:ding "dong" '((zim "zam"))]{hello})
   (check-txexprs-equal? ◊foolam['zim: "zam" #:ding "dong" ]{hello} ◊foo2['zim: "zam" #:ding "dong" ]{hello}))
\ No newline at end of file