a conundrum

quad/qtest/hyphenate.rkt

@@ -1,60 +1,5 @@
 #lang qtest/markdown
 
-# Hyphenate
+X
 
-A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX.
-
-I **have added little** to their work. Accordingly, I take no credit, except a spoonful of *snako-bits.*
-
-And now, for something __altogether__ the same. Yes! No?!ß
-
-## 1. Installation
-
-At the command line:
-
-We said `raco pkg install hyphenate` dude
-
-What?!
-
-```
-Code block
-Goes here
-```
-
-> Hyphenate `xexpr` by calculating hyphenation points and inserting
-`joiner` at those points. By default, `joiner` is the soft hyphen
-\(Unicode 00AD = decimal 173\). Words shorter than
-`#:min-length` `length` will not be hyphenated. To hyphenate words of
-any length, use `#:min-length` `#f`.
-
-A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
-Certain word processors allow users to [insert soft
-hyphens](http://practicaltypography.com/optional-hyphens.html) in their
-text.
+Y

quad/qtest/markdown.rkt

@@ -2,39 +2,37 @@
 (require (for-syntax racket/base) txexpr racket/runtime-path racket/string racket/promise racket/match racket/list
          pitfall quad sugar/debug pollen/tag)
 (provide (except-out (all-from-out racket/base) #%module-begin)
-         (rename-out [mb #%module-begin] [q-tag q])
+         (rename-out [mb #%module-begin])
          p id strong em attr-list h1 h2 code pre a blockquote)
 
 (define-tag-function (p attrs exprs)
-  (txexpr 'q attrs exprs))
+  (qexpr attrs exprs))
 
 (define-tag-function (blockquote attrs exprs)
-  (txexpr 'q (cons '(container "bq") attrs) exprs))
+  (qexpr (cons '(container "bq") attrs) exprs))
 
 (define id (default-tag-function 'id))
 (define class (default-tag-function 'class))
 
-(define q-tag (default-tag-function 'q))
-
 (define-tag-function (strong attrs exprs)
-  (txexpr 'q (cons '(font "charter-bold") attrs) exprs))
+  (qexpr (cons '(font "charter-bold") attrs) exprs))
 
 (define-tag-function (a attrs exprs)
-  (txexpr 'q `((link ,(cadr (assoc 'href attrs)))(color "MediumVioletRed")) exprs))
+  (qexpr `((link ,(cadr (assoc 'href attrs)))(color "MediumVioletRed")) exprs))
 
 (define-tag-function (em attrs exprs)
-  (txexpr 'q (cons '(font "charter-italic") attrs) exprs))
+  (qexpr (cons '(font "charter-italic") attrs) exprs))
 
 (define-syntax-rule (attr-list . attrs) 'attrs)
 
 (define-tag-function (h1 attrs exprs)
-  (txexpr 'q (append  '((font "fira")(fontsize "36")(line-height "48")) attrs) exprs))
+  (qexpr (append  '((font "fira")(fontsize "36")(line-height "48")) attrs) exprs))
 
 (define-tag-function (h2 attrs exprs)
-  (txexpr 'q (append '((font "fira")(fontsize "24")(line-height "36")) attrs)  exprs))
+  (qexpr (append '((font "fira")(fontsize "24")(line-height "36")) attrs)  exprs))
 
 (define-tag-function (code attrs exprs)
-  (txexpr 'q (append '((font "fira-mono")(fontsize "11")(bg "aliceblue")) attrs)  exprs))
+  (qexpr (append '((font "fira-mono")(fontsize "11")(bg "aliceblue")) attrs)  exprs))
 
 (define-tag-function (pre attrs exprs)
   ;; pre needs to convert white space to equivalent layout elements
@@ -42,8 +40,8 @@
                      (for*/list ([expr (in-list exprs)]
                                  [str (in-list (string-split (car (get-elements expr)) "\n"))])
                                 `(,(get-tag expr) ,(get-attrs expr) ,str))
-                     '(q "¶")))
-  (txexpr 'q attrs new-exprs))
+                     lbr))
+  (qexpr attrs new-exprs))
 
 (define q:string (q #:in 'bi
                     #:out 'bo ;; align to baseline
@@ -70,30 +68,33 @@
 (define-runtime-path fira-mono "fonts/fira-mono.ttf")
 
 (define (->string-quad doc q)
-  (struct-copy
-   quad q:string
-   [attrs (let ([attrs (quad-attrs q)])
-            ;; attrs hashes are shared between many quads.
-            ;; so the first update will change every reference to the shared hash
-            ;; hence why we ignore if val is already a path
-            ;; but this op should ideally happen earlier
-            (hash-update! attrs 'font
-                          (λ (val) (if (path? val)
-                                       val
-                                       (match (string-downcase (string-replace val " " "-"))
-                                         ["charter" charter]
-                                         ["charter-bold" charter-bold]
-                                         ["charter-italic" charter-italic]
-                                         ["fira" fira]
-                                         ["fira-mono" fira-mono]))))
-            attrs)]
-   [elems (quad-elems q)]
-   [size (delay
-           (define fontsize (string->number (hash-ref (quad-attrs q) 'fontsize)))
-           (font-size doc fontsize)
-           (font doc (path->string (hash-ref (quad-attrs q) 'font)))
-           (define str (car (quad-elems q)))
-           (pt (string-width doc str) (current-line-height doc)))]))
+  (cond
+    [(line-break? q) q]
+    [else
+     (struct-copy
+      quad q:string
+      [attrs (let ([attrs (quad-attrs q)])
+               ;; attrs hashes are shared between many quads.
+               ;; so the first update will change every reference to the shared hash
+               ;; hence why we ignore if val is already a path
+               ;; but this op should ideally happen earlier
+               (hash-update! attrs 'font
+                             (λ (val) (if (path? val)
+                                          val
+                                          (match (string-downcase (string-replace val " " "-"))
+                                            ["charter" charter]
+                                            ["charter-bold" charter-bold]
+                                            ["charter-italic" charter-italic]
+                                            ["fira" fira]
+                                            ["fira-mono" fira-mono]))))
+               attrs)]
+      [elems (quad-elems q)]
+      [size (delay
+              (define fontsize (string->number (hash-ref (quad-attrs q) 'fontsize)))
+              (font-size doc fontsize)
+              (font doc (path->string (hash-ref (quad-attrs q) 'font)))
+              (define str (car (quad-elems q)))
+              (pt (string-width doc str) (current-line-height doc)))])]))
 
 (define draw? #f)
 (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"])
@@ -145,15 +146,29 @@
     (values (cons new-run runs) rest)))
 
 
-(struct line-break quad ())
+(struct line-break quad () #:transparent)
+(define lbr (q #:type line-break
+               #:elems '("¶")
+               #:printable #f))
+(struct para-break line-break () #:transparent)
+(define pbr (q #:type para-break
+               #:elems '("¶¶")
+               #:printable #f))
+
+(module+ test
+  (check-true (line-break? (second (quad-elems (q "foo" pbr "bar")))))
+  (check-true (line-break? (second (atomize (q "foo" pbr "bar"))))))
 
 (define (line-wrap xs size)
-  (wrap xs size
-        #:hard-break (λ (q) (match (quad-elems q)
-                              [(list (or "¶¶" "¶")) #t]
-                              [_ #f]))
+  #R xs
+  #R (line-break? (second xs))
+  (wrap xs size 'debug
+        #:hard-break line-break?
         #:soft-break soft-break-for-line?
         #:finish-wrap (λ (pcs q idx)
+                        #R pcs
+                        #R q
+                        #R idx
                         (define new-elems (consolidate-runs pcs))
                         (append
                          (list (struct-copy quad q:line
@@ -187,6 +202,8 @@
                   #:draw-start (λ (q doc) (add-page doc))
                   #:draw-end (λ (q doc)
                                (font-size doc 10)
+                               (font doc charter)
+                               (fill-color doc "black")
                                (text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number)
                                                  (hash-ref (quad-attrs q) 'doc-title)
                                                  (date->string (current-date) #t))
@@ -265,8 +282,10 @@
                                             #:size "letter")))
   (define line-width (- (pdf-width pdf) (* 2 side-margin)))
   (define vertical-height (- (pdf-height pdf) top-margin bottom-margin))
-  (let* ([x (time-name runify (runify (qexpr->quad xs)))]
+  (let* ([x (time-name atomize #R (atomize #R (qexpr->quad xs)))]
+         [x (begin #R (line-break? (second x)) x)]
          [x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))]
+         [x (begin #R (line-break? (second x)) x)]
          [x (time-name line-wrap (line-wrap x line-width))]
          [x (time-name page-wrap (page-wrap x vertical-height path))]
          [x (time-name insert-containers (insert-containers x))]
@@ -277,7 +296,7 @@
   (syntax-case stx ()
     [(_ PDF-PATH . STRS)
      #'(#%module-begin
-        (define qx `(q ((font "Charter") (fontsize "12")) ,@(list . STRS)))
+        (define qx (list* 'q '((font "Charter") (fontsize "12")) (add-between (list . STRS) pbr)))
         (run qx PDF-PATH))]))
 
 (module+ reader
@@ -302,7 +321,7 @@
                             #:inside? #t
                             #:command-char #\◊))
     (define stx (quad-at-reader path-string p))
-    (define parsed-stx (datum->syntax stx (xexpr->parse-tree (add-between (parse-markdown (apply string-append (syntax->datum stx))) '(q "¶¶")))))
+    (define parsed-stx (datum->syntax stx (xexpr->parse-tree (parse-markdown (apply string-append (syntax->datum stx))))))
     (strip-context
      (with-syntax ([PT parsed-stx]
                    [PDF-PATH (path-replace-extension path-string #".pdf")])

quad/qtest/typewriter.rkt

@@ -128,7 +128,7 @@
   (time-name config-pdf
              (font pdf (path->string charter))
              (font-size pdf 12))
-  (let* ([x (time-name runify (runify qarg))]
+  (let* ([x (time-name atomize (atomize qarg))]
          [x (time-name quadify (map (λ (x) (quadify pdf x)) x))]
          [x (time-name line-wrap (line-wrap x line-width))]
          [x (time-name page-wrap (page-wrap x lines-per-page))]

quad/quad/atomize.rkt

@@ -1,8 +1,16 @@
 #lang debug racket/base
-(require racket/string racket/hash racket/class racket/match racket/list txexpr racket/dict racket/function
-         "quad.rkt" "param.rkt")
+(require racket/string
+         racket/hash
+         racket/match
+         racket/list
+         txexpr
+         racket/function
+         "quad.rkt"
+         "param.rkt")
 (provide (all-defined-out))
-(module+ test (require rackunit))
+
+(module+ test
+  (require rackunit))
 
 (define (update-with base-hash . update-hashes)
   ;; starting with base-hash, add or update keys found in update-hashes
@@ -15,72 +23,8 @@
    ((hasheq 'foo "bar" 'zim "zam") . update-with .  (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay"))
    (make-hasheq '((zim . "BANG") (foo . "zay") (toe . "jam")))))
 
-(define (merge-whitespace qs [white-q? (λ (aq) (char-whitespace? (car (quad-elems aq))))])
-  ;; collapse each sequence of whitespace qs to the first one, and make it a space
-  ;; also drop leading & trailing whitespaces
-  ;; (same behavior as web browsers)
-  (let loop ([acc null][qs qs])
-    (if (null? qs)
-        (flatten acc)
-        (let*-values ([(bs rest) (splitf-at qs (negate white-q?))]
-                      [(ws rest) (splitf-at rest white-q?)])
-          (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)
-                                 null)) rest)))))
-
-
-(module+ test
-  (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 qx) qx)][attrs (current-default-attrs)])
-      (match x
-        [(? 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
-         (define this-attrs (quad-attrs x))
-         (define elems (quad-elems x))
-         (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)])))
-  (merge-whitespace atomic-quads))
-
-(module+ test
-  (require rackunit)
-  (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 (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 (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
-                 (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
-                 (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)
   (for/list ([(m idx) (in-indexed (regexp-match* whitespace-pat str #:gap-select? #t))]
              #:when (non-empty-string? m))
@@ -101,36 +45,54 @@
 (define (same-run? qa qb)
   (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",
+(define (atomize qx)
+  ;; atomize a quad by reducing it to the smallest indivisible formatting units.
   ;; which are multi-character quads with the same formatting.
-  (define first-run-idx (eq-hash-code (current-default-attrs)))
-  (define first-attrs (hash-copy (current-default-attrs)))
-  (hash-set! first-attrs run-key first-run-idx)
-  (dropf
-   (let loop ([x (if (string? qx) (make-quad #f (list qx)) qx)]
-              [attrs first-attrs]
-              [key first-run-idx])
-     (match x
-       [(? quad?) ;; qexprs with attributes are recursed
-        (define this-attrs (quad-attrs x))
-        (define elems (quad-elems x))
-        (define next-key (if (hash-empty? this-attrs) key (eq-hash-code this-attrs)))
-        (define next-attrs (if (hash-empty? this-attrs) attrs (attrs . update-with . this-attrs)))
-        (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 elem))
-                               (loop elem next-attrs next-key))))]))
-   (λ (q) (string=? " " (car (quad-elems q))))))
+  (let loop ([x (make-quad qx)]
+             [attrs (hash-copy (current-default-attrs))]
+             [key (eq-hash-code (current-default-attrs))])
+    (match-define-values (next-key next-attrs)
+      ;; make a new run when we encounter non-empty attrs
+      (match (quad-attrs x)
+        [(? hash-empty?) (values key attrs)]
+        [this-attrs (define next-key (eq-hash-code this-attrs))
+                    (define next-attrs (attrs . update-with . this-attrs))
+                    (hash-set! next-attrs run-key next-key)
+                    (values next-key next-attrs)]))
+    (match (quad-elems x)
+      [(? pair? elems)
+       (append* 
+        (for/list ([elem (in-list (merge-adjacent-strings elems 'isolate-white))])
+                  (match elem
+                    [(? string?)
+                     #|
+190116
+The conundrum: how to atomize quads that have subtypes and possibly other fields.
+We need to make new quads derived from the original.
+But we don't have access to the subtype here.
+Making the quad mutable doesn't solve the problem: we can change the first one, but we still need copies.
+`struct-copy` doesn't work, because it can't see the subtype.
+`struct-list` doesn't work, because it can't rely on structs being transparent.
+|#
+                     (list (make-quad #:type (quad-type x)
+                                      #:attrs next-attrs
+                                      #:elems (list elem)))]
+                    [_ (loop elem next-attrs next-key)])))]
+      [_ (list x)])))
 
-#;(module+ test
-    ;; this test doesn't work because of presence of 'idx and 'run keys
-    (check-equal?
-     (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"))))
-   
+(module+ test
+  (define (filter-private-keys qs)
+    (for-each (λ (q) (when (hash-has-key? (quad-attrs q) 'run)
+                       (hash-remove! (quad-attrs q) 'run))) qs)
+    qs)
+  (struct $br quad ())
+  (define br (q #:type $br (hasheq 'br "time")))
+  (check-equal? (filter-private-keys (atomize (q (q "a b") br (q "x y"))))
+                (list (q "a") (q " ") (q "b") br (q "x") (q " ") (q "y")))  
+  (check-equal?
+   (filter-private-keys (atomize (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/qexpr.rkt

@@ -1,49 +1,59 @@
 #lang debug racket/base
 (require xml
-         racket/contract
-         racket/class
          racket/dict
          racket/string
          racket/match
          racket/list
          txexpr 
-         "quad.rkt" sugar/debug)
+         "quad.rkt")
 (provide (all-defined-out))
 
 (module+ test (require rackunit))
 
-(define/contract (qexpr? x)
-  ;; a qexpr is like an xexpr, but more lenient in some ways (allows single char as body element)
-  ;; and less in others (only allows 'q or 'quad as tag names)
-  (any/c . -> . boolean?)
-  (define (valid-tag? tag) (and (memq tag '(q quad)) #t))
+;; should we allow quads within a qexpr? I say yes
+(define permissive-qexprs (make-parameter #t))
+
+(define (valid-tag? tag) (and (memq tag '(q quad)) #t))
+
+(define (qexpr? x)
+  ;; a qexpr is like an xexpr, but more lenient in some ways (possibly allows quads)
+  ;; and less in others (only allows 'q or 'quad as tag names, only allows strings or qexprs as elements)
+  ;; attrs are open-ended
   (match x
-    [(? txexpr?) #t]
-    [(list (? symbol? tag) (? char? c)) #t]
+    [(cons (? valid-tag?) rest)
+     (match rest
+       [(list (? txexpr-attrs?) (? qexpr?) ...) #t]
+       [(list (? qexpr?) ...) #t]
+       [_ #f])]
     [(? string?) #t]
-    [else #f]))
+    [(? quad?) (permissive-qexprs)]
+    [_ #f]))
 
 
 (module+ test
   (check-true (qexpr? "Hello world"))
   (check-true (qexpr? '(q "Hello world")))
   (check-true (qexpr? '(quad "Hello world")))
-  #;(check-false (qexpr? '(div "Hello world")))
-  (check-true (qexpr? '(q #\H)))
-  (check-true (qexpr? '(quad #\H)))
-  #;(check-false (qexpr? '(span #\H)))
+  (check-false (qexpr? '(div "Hello world")))
+  (check-false (qexpr? '(q #\H)))
+  (check-false (qexpr? '(quad #\H)))
+  (check-false (qexpr? '(span #\H)))
   (check-true (qexpr? '(quad "Hello world")))
-  (check-false (qexpr? 'q)))
+  (check-true (qexpr? `(quad "Hello " ,(q "world")))))
 
 (define (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$")))
 
-(define/contract (qexpr #:clean-attrs? [clean-attrs? #f]
-                        #:name [name 'q]
-                        attrs . elems)
-  ((txexpr-attrs?) (#:clean-attrs? any/c #:name txexpr-tag?) #:rest (or/c txexpr-elements? (list/c char?)) . ->* . qexpr?)
-  (txexpr name (if clean-attrs? (remove-duplicates attrs #:key car) attrs) (match elems
-                                                                             [(list (? char? c)) (list (string c))]
-                                                                             [else elems])))
+(define (qexpr #:clean-attrs? [clean-attrs? #f]
+               #:name [name 'q]
+               attrs . elems)
+  (define new-attrs (if clean-attrs? (remove-duplicates attrs #:key car) attrs))
+  (define new-elems (match elems
+                      [(list (? char? c)) (list (string c))]
+                      [(list (? list? xs)) xs]
+                      [else elems]))
+  (cond
+    [(empty? new-attrs) (list* name new-elems)]
+    [else (list* name new-attrs new-elems)]))
 
 (module+ test
   (check-equal? (qexpr null "foo") '(q "foo"))
@@ -53,30 +63,38 @@
 
 (define (hash->qattrs attr-hash)
   (for/list ([(k v) (in-dict (hash->list attr-hash))])
-    (list k (format "~a" v))))
+            (list k (format "~a" v))))
 
-(define/contract (quad->qexpr q)
-  (quad? . -> . qexpr?)
+(define (quad->qexpr q)
   (let loop ([x q])
     (cond
       [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->qattrs (quad-attrs x)) (map loop (quad-elems x)))]
       [else x])))
 
-(define/contract (qexpr->quad x)
-  (qexpr? . -> . quad?)
-  (if (txexpr? x)
-      (q #:attrs (attrs->hash (get-attrs x))
-         #:elems (map qexpr->quad (get-elements x)))
-      x))
+(define (qexpr->quad x)
+  (unless (qexpr? x)
+    (raise-argument-error 'qexpr->quad "qexpr" x))
+  (let loop ([x x])
+    (match x
+      [(cons (? valid-tag?) rest)
+       (match rest
+         [(list (? txexpr-attrs? attrs) (? qexpr? elems) ...)
+          (q #:attrs (attrs->hash attrs) #:elems (map loop elems))]
+         [(list (? qexpr? elems) ...)
+          (q #:elems (map loop elems))])]
+      [_ x])))
+
+(module+ test
+  (check-equal?
+   (qexpr->quad  `(q ((font "Charter") (fontsize "12")) (q "Foo bar") ,(make-quad "zzz") (q "Zim Zam")))
+   (q (hasheq 'font "Charter" 'fontsize "12") (q "Foo bar") (q "zzz") (q "Zim Zam"))))
 
-(define/contract (qml->qexpr x)
-  (string? . -> . qexpr?)
+(define (qml->qexpr x)
   (parameterize ([permissive-xexprs #t]
                  [xexpr-drop-empty-attributes #t])
     (string->xexpr x)))
 
-(define/contract (qexpr->qml x)
-  (qexpr? . -> . string?)
+(define (qexpr->qml x)
   (xexpr->string x))
 
 (module+ test

quad/quad/quad.rkt

@@ -34,7 +34,8 @@
    ;; and compare them key-by-key
    (hashes-equal? (quad-attrs q1) (quad-attrs q2))))
 
-(struct quad (attrs
+(struct quad (type
+              attrs
               elems
               size
               in
@@ -84,12 +85,16 @@
          #:draw [draw default-draw]
          #:draw-end [draw-end void]
          . args)
+  (unless (andmap (λ (x) (not (pair? x))) elems)
+    (raise-argument-error 'make-quad "elements that are not lists" elems))
   (match args
     [(list (== #false) elems ...) (make-quad #:elems elems)]
     [(list (? hash? attrs) elems ...) (make-quad #:attrs attrs #:elems elems)]
     [(list (? dict? assocs) elems ...) assocs (make-quad #:attrs (make-hasheq assocs) #:elems elems)]
     [(list elems ..1) (make-quad #:elems elems)]
-    [null (type attrs
+    ;; all cases end up below
+    [null (type type
+                attrs
                 elems
                 size
                 in

quad/quad/wrap.rkt

@@ -280,7 +280,8 @@
 
 (define (visual-wrap str int [debug #f])
   (string-join
-   (for/list ([x (in-list (linewrap (for/list ([atom (atomize str)])
+   (for/list ([x (in-list (linewrap (for/list ([c (in-string str)])
+                                              (define atom (q c))
                                               (if (equal? (quad-elems atom) '(#\space))
                                                   (struct-copy quad sp)
                                                   (struct-copy quad q-one