From eb0e996689befef9562dce97982f465c4f478f46 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Thu, 20 Feb 2014 18:06:50 -0800
Subject: [PATCH] add simplified notation for attributes in #%top

---
 top.rkt | 34 ++++++++++++++++++++++++++++------
 1 file changed, 28 insertions(+), 6 deletions(-)

diff --git a/top.rkt b/top.rkt
index 3c31a15..b640464 100644
--- a/top.rkt
+++ b/top.rkt
@@ -11,12 +11,34 @@
 (provide (except-out (all-defined-out) top~)
          (rename-out (top~ #%top)))
 
+;; Allow tag attributes to be specified as follows:
+;; @foo['shape: "square" 'color: "red"]{hello}
 (define-syntax-rule (top~ . id)
-  (λ x `(id ,@x)))
+  (λ x 
+    (define attrs null)
+    (define elements 
+      (let chomp ([x x])
+        (define result+regexp (and ((length x) . >= . 2) 
+                                         (symbol? (car x)) 
+                                         ;; accept strings only
+                                         ;; numbers are difficult because they don't parse as cleanly.
+                                         ;; string will read as a string even if there's no space to the left.
+                                         (or (string? (cadr x))) 
+                                         ;; Looking for symbol ending with a colon
+                                         (regexp-match #rx"^(.*?):(.*)$" (symbol->string (car x)))))
+        (if result+regexp
+            (begin
+               ; reuse result value cadr is first group in match. 
+              (set! attrs (cons (list (string->symbol (cadr result+regexp))(cadr x)) attrs))
+              (chomp (cddr x)))
+            x)))
+    
+    `(id ,@(if (equal? attrs null) null (list (reverse attrs))) ,@elements)))
+
 
 (define-syntax (bound/c stx)
-   (syntax-case stx ()
-     [(_ x)
-      (if (identifier-binding #'x )
-          #'x
-          #'(#%top . x))]))
+  (syntax-case stx ()
+    [(_ x)
+     (if (identifier-binding #'x )
+         #'x
+         #'(#%top . x))]))