touches

quad/quad/atomize.rkt

@@ -1,5 +1,5 @@
 #lang debug racket/base
-(require racket/string racket/class racket/match racket/list txexpr racket/dict racket/function
+(require racket/string racket/hash racket/class racket/match racket/list txexpr racket/dict racket/function
          "quad.rkt" "param.rkt")
 (provide (all-defined-out))
 (module+ test (require rackunit))
@@ -7,8 +7,7 @@
 (define (update-with base-hash . update-hashes)
   ;; starting with base-hash, add or update keys found in update-hashes
   (define h (make-hasheq))
-  (for ([(k v) (in-dict (append-map hash->list (list* base-hash update-hashes)))])
-       (hash-set! h k v))
+  (apply hash-union! #:combine (λ (v1 v2) v2) h base-hash update-hashes)
   h)
 
 (module+ test
@@ -28,23 +27,21 @@
           (loop (list acc bs (if (and (pair? rest) ;; we precede bs (only #t if rest starts with bs, because we took the ws)
                                       (pair? bs) ;; we follow bs
                                       (pair? ws)) ;; we have ws
-                                 (make-quad (quad-attrs (car ws)) '(#\space))
+                                 (make-quad (quad-attrs (car ws)) #\space)
                                  null)) rest)))))
 
 
 (module+ test
-  (define (qq . xs) (q #f xs))
-  (define (qqa attrs . xs) (q attrs xs))
-  (check-equal? (merge-whitespace (list (qq #\space) (qq #\newline) (qq #\H) (qq #\space) (qq #\newline) (qq #\space) (qq #\i) (qq #\newline)))
-                (list (qq #\H) (qq #\space) (qq #\i))))
+  (check-equal? (merge-whitespace (list (q #\space) (q #\newline) (q #\H) (q #\space) (q #\newline) (q #\space) (q #\i) (q #\newline)))
+                (list (q #\H) (q #\space) (q #\i))))
 
 (define (atomize qx)
   ;; normalize a quad by reducing it to one-character quads.
   ;; propagate attrs downward.
   (define atomic-quads
-    (let loop ([x (if (string? qx) (q #f (list qx)) qx)][attrs (current-default-attrs)])
+    (let loop ([x (if (string? qx) (q #f qx) qx)][attrs (current-default-attrs)])
       (match x
-        [(? char? c) (list (q attrs (list c)))]
+        [(? char? c) (list (q attrs c))]
         [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
                                         (loop c attrs)))]
         [(? quad?) ;; qexprs with attributes are recursed
@@ -58,30 +55,30 @@
 
 (module+ test
   (require rackunit)
-  (check-equal? (atomize (qq "Hi")) (list (qq #\H) (qq #\i)))
-  (check-equal? (atomize (qq "Hi " (qq "You"))) (list (qq #\H) (qq #\i) (qq #\space) (qq #\Y) (qq #\o) (qq #\u)))
+  (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)))
-  (check-equal? (atomize (qq "H i")) (list (qq #\H) (qq #\space) (qq #\i)))
-  (check-equal? (atomize (qq "H \n\n i")) (list (qq #\H) (qq #\space) (qq #\i))) ;; collapse whitespace to single
+  (check-equal? (atomize (q "H i")) (list (q #\H) (q #\space) (q #\i)))
+  (check-equal? (atomize (q "H \n\n i")) (list (q #\H) (q #\space) (q #\i))) ;; collapse whitespace to single
 
   ;; with attributes
-  (check-equal? (atomize (qqa (hasheq 'k "v") "Hi")) (list (qqa (hasheq 'k "v") #\H) (qqa (hasheq 'k "v") #\i)))
-  (check-equal? (atomize (qqa (hasheq 'k "v") "Hi " (qq "You")))
+  (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
-                 (qqa (hasheq 'k "v") #\H)
-                 (qqa (hasheq 'k "v") #\i)
-                 (qqa (hasheq 'k "v") #\space)
-                 (qqa (hasheq 'k "v") #\Y)
-                 (qqa (hasheq 'k "v") #\o)
-                 (qqa (hasheq 'k "v") #\u)))
-  (check-equal? (atomize (qqa (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (qqa (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou")))
+                 (q (hasheq 'k "v") #\H)
+                 (q (hasheq 'k "v") #\i)
+                 (q (hasheq 'k "v") #\space)
+                 (q (hasheq 'k "v") #\Y)
+                 (q (hasheq 'k "v") #\o)
+                 (q (hasheq 'k "v") #\u)))
+  (check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (q (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou")))
                 (list
-                 (qqa (hasheq 'k1 "v1" 'k2 42) #\H)
-                 (qqa (hasheq 'k1 "v1" 'k2 42) #\i)
-                 (qqa (hasheq 'k1 "v1" 'k2 42) #\space)
-                 (qqa (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y)
-                 (qqa (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o)
-                 (qqa (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u))))
+                 (q (hasheq 'k1 "v1" 'k2 42) #\H)
+                 (q (hasheq 'k1 "v1" 'k2 42) #\i)
+                 (q (hasheq 'k1 "v1" 'k2 42) #\space)
+                 (q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y)
+                 (q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o)
+                 (q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u))))
 
 (define whitespace-pat #px"\\s+")
 (define (merge-and-isolate-white str)
@@ -102,7 +99,7 @@
 (define run-key 'run)
 
 (define (same-run? qa qb)
-  (eq? (hash-ref (get-field attrs qa) run-key) (hash-ref (get-field attrs qb) run-key)))
+  (eq? (hash-ref (quad-attrs qa) run-key) (hash-ref (quad-attrs qb) run-key)))
 
 (define (runify qx)
   ;; runify a quad by reducing it to a series of "runs",
@@ -123,16 +120,17 @@
         (unless (hash-empty? this-attrs) (hash-set! next-attrs run-key next-key))
         (append* (for/list ([elem (in-list (merge-adjacent-strings elems 'merge-white))])
                            (if (string? elem)
-                               (list (make-quad next-attrs (list elem)))
+                               (list (make-quad next-attrs elem))
                                (loop elem next-attrs next-key))))]))
    (λ (q) (string=? " " (car (quad-elems q))))))
 
 #;(module+ test
+    ;; this test doesn't work because of presence of 'idx and 'run keys
     (check-equal?
-     (runify (qqa (hasheq 'foo 42) (qq "Hi" "    idiot" (qqa (hasheq 'bar 84) "There") "Eve" "ry" "one")))
-     (list (qqa (hasheq 'foo 42) "Hi")
-           (qqa (hasheq 'foo 42) " ")
-           (qqa (hasheq 'foo 42) "idiot")
-           (qqa (hasheq 'foo 42 'bar 84) "There")
-           (qqa (hasheq 'foo 42) "Everyone"))))
+     (runify (q (hasheq 'foo 42) (q "Hi" "    idiot" (q (hasheq 'bar 84) "There") "Eve" "ry" "one")))
+     (list (q (hasheq 'foo 42) "Hi")
+           (q (hasheq 'foo 42) " ")
+           (q (hasheq 'foo 42) "idiot")
+           (q (hasheq 'foo 42 'bar 84) "There")
+           (q (hasheq 'foo 42) "Everyone"))))
    

quad/quad/quad.rkt

@@ -1,5 +1,5 @@
 #lang debug racket/base
-(require racket/struct)
+(require racket/struct racket/dict racket/match)
 (provide (all-defined-out))
 (module+ test (require rackunit))
 
@@ -40,7 +40,11 @@
 
 (define (default-printable [sig #f]) #f)
 
-(define (make-quad [attrs #f] [elems null])
+;; todo: convert immutable hashes to mutable on input?
+(define make-quad
+  (match-lambda*
+    [(list (== #false) elems ...) elems (apply make-quad (make-hasheq) elems)]
+    [(list (? hash? attrs) elems ...)
   ;; why 'nw and 'ne as defaults for in and out points:
   ;; if size is '(0 0), 'nw and 'ne are the same point,
   ;; and everything piles up at the origin
@@ -69,7 +73,9 @@
         printable
         pre-draw
         post-draw
-        draw))
+        draw)]
+    [(list (? dict? assocs) elems ...) assocs (apply make-quad (make-hasheq assocs) elems)]
+    [(list elems ...) (apply make-quad #f elems)]))
 
 (define q make-quad)