structs instead

quad/quad/atomize.rkt

@@ -1,42 +1,53 @@
-#lang racket/base
-(require racket/contract racket/match racket/list txexpr sugar/debug
-         "qexpr.rkt" "param.rkt")
+#lang sugar/debug racket/base
+(require racket/contract racket/match racket/list txexpr racket/dict
+         "quad.rkt" "qexpr.rkt" "param.rkt")
 (provide (all-defined-out))
 
+(define (update-with base-hash . update-hashes)
+  ;; starting with base-hash, add or update keys found in update-hashes
+  (apply hasheq (flatten (map hash->list (list* base-hash update-hashes)))))
+
+(module+ test
+  (check-equal?
+   ((hasheq 'foo "bar" 'zim "zam") . update-with .  (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay"))
+   '#hasheq((zim . "BANG") (foo . "zay") (toe . "jam"))))
+
 (define/contract (atomize qx)
-  ;; normalize a qexpr by reducing it to one-character quads.
-  ;; propagate attrs downward by appending to front of attrs list.
-  ;; ok to have duplicate attrs (leftmost attr takes precedence)
-  (qexpr? . -> . (listof qexpr?))
+  ;; normalize a quad by reducing it to one-character quads.
+  ;; propagate attrs downward.
+  (quad? . -> . atomic-quads?)
   (let loop ([x qx][attrs (current-default-attrs)])
     (match x
-      [(? string?) (for/list ([c (in-string x)]) ;; strings are exploded
-                     (qexpr attrs (string c)))]
-      [(list (? symbol?) (? txexpr-attrs? new-attrs) xs ...) ;; qexprs with attributes are recursed
-       (append* (for/list ([x (in-list xs)])
-                  (loop x (append new-attrs attrs))))]
-      [(list (? symbol? tag) xs ...) (loop (list* tag null xs) attrs)] ;; qexprs without attributes get null attrs
+      [(? char? c) (list (q attrs c))]
+      [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
+                                      (loop c attrs)))]
+      [($quad this-attrs elems) ;; qexprs with attributes are recursed
+       (define merged-attrs (attrs . update-with . this-attrs))
+       (append* (for/list ([elem (in-list elems)])
+                          (loop elem merged-attrs)))]
       [else (raise-argument-error 'atomize "valid item" x)])))
 
 (module+ test
   (require rackunit)
-  (check-equal? (atomize "Hi") '((q "H") (q "i")))
-  (check-equal? (atomize '(q "Hi " (q "You"))) '((q "H") (q "i") (q " ") (q "Y") (q "o") (q "u")))
-  (check-exn exn:fail? (λ () (atomize #t)))
+  (check-equal? (atomize (q "Hi")) (list (q #\H) (q #\i)))
+  (check-equal? (atomize (q "Hi " (q "You"))) (list (q #\H) (q #\i) (q #\space) (q #\Y) (q #\o) (q #\u)))
+  (check-exn exn:fail:contract? (λ () (atomize #t)))
 
   ;; with attributes
-  (check-equal? (atomize '(q ((k "v")) "Hi")) '((q ((k "v")) "H") (q ((k "v")) "i")))
-  (check-equal? (atomize '(q ((k "v")) "Hi " (q "You")))
-                '((q ((k "v")) "H")
-                  (q ((k "v")) "i")
-                  (q ((k "v")) " ")
-                  (q ((k "v")) "Y")
-                  (q ((k "v")) "o")
-                  (q ((k "v")) "u")))
-  (check-equal? (atomize '(q ((k1 "v1")(k2 "42")) "Hi " (q ((k1 "v2")(k3 "foo")) "You")))
-                '((q ((k1 "v1") (k2 "42")) "H")
-                  (q ((k1 "v1") (k2 "42")) "i")
-                  (q ((k1 "v1") (k2 "42")) " ")
-                  (q ((k1 "v2") (k3 "foo") (k1 "v1") (k2 "42")) "Y")
-                  (q ((k1 "v2") (k3 "foo") (k1 "v1") (k2 "42")) "o")
-                  (q ((k1 "v2") (k3 "foo") (k1 "v1") (k2 "42")) "u"))))
+  (check-equal? (atomize (q (hasheq 'k "v") "Hi")) (list (q (hasheq 'k "v") #\H) (q (hasheq 'k "v") #\i)))
+  (check-equal? (atomize (q (hasheq 'k "v") "Hi " (q "You")))
+                (list
+                 ($quad '#hasheq((k . "v")) '(#\H))
+                 ($quad '#hasheq((k . "v")) '(#\i))
+                 ($quad '#hasheq((k . "v")) '(#\space))
+                 ($quad '#hasheq((k . "v")) '(#\Y))
+                 ($quad '#hasheq((k . "v")) '(#\o))
+                 ($quad '#hasheq((k . "v")) '(#\u))))
+  (check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi " (q (hasheq 'k1 "v2" 'k3 "foo") "You")))
+                (list
+                 ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\H))
+                 ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\i))
+                 ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\space))
+                 ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\Y))
+                 ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\o))
+                 ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\u)))))

quad/quad/param.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
 (provide (all-defined-out))
 
-(define current-default-attrs (make-parameter null))
+(define current-default-attrs (make-parameter (make-hasheq)))
 (define current-line-width (make-parameter 1))

quad/quad/quad.rkt

@@ -0,0 +1,33 @@
+#lang sugar/debug racket/base
+(require racket/match racket/function)
+(provide (all-defined-out))
+(module+ test (require rackunit))
+
+(struct $quad (attrs elems) #:transparent)
+(define quad? $quad?)
+(define (quad-attrs? x) (and (hash? x) (hash-eq? x)))
+(define (quad-elem? x) (or (char? x) (string? x) ($quad? x)))
+(define (quad-elems? xs) (and (pair? xs) (andmap quad-elem? xs)))
+(define (quad . xs)
+  (match xs
+    [(list #f xs ...) (apply quad (hasheq) xs)]
+    [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) ($quad attrs elems)]
+    [(list (? quad-elem? elems) ...) (apply quad #f elems)]
+    [else (error 'bad-quad-input)]))
+(define (quads? xs) (and (pair? xs) (andmap quad? xs)))
+(define (atomic-quad? x) (and (quad? x) (match (qe x)
+                                         [(list (? char?)) #t]
+                                         [else #f])))
+(define (atomic-quads? xs) (and (pair? xs) (andmap atomic-quad? xs)))
+(module+ test
+  (check-true (atomic-quad? ($quad '#hasheq() '(#\H))))
+  (check-true (atomic-quads? (list ($quad '#hasheq() '(#\H))))))
+
+(define quad-attrs $quad-attrs)
+(define quad-elems $quad-elems)
+
+(define q quad)
+(define q? quad?)
+(define qs? quads?)
+(define qa quad-attrs)
+(define qe quad-elems)