Merge branch 'main' of https://github.com/mbutterick/typesetting

quad2/attr-passes.rkt

@@ -0,0 +1,205 @@
+#lang debug racket/base
+(require racket/match
+         racket/string
+         racket/set
+         "attr.rkt"
+         "dimension.rkt"
+         "pipeline.rkt"
+         "struct.rkt"
+         "constants.rkt"
+         "quad.rkt"
+         "param.rkt")
+(provide (all-defined-out))
+
+(module+ test
+  (require rackunit))
+
+(define (for-each-attrs xs proc)
+  ;; apply `proc` to each set of attrs in `xs`.
+  ;; recursively descend from top to bottom.
+  ;; but also track which attrs are visited and skip any already visited.
+  (define attrs-seen (mutable-seteq))
+  (define wants-parent-attrs? (= (procedure-arity proc) 2))
+  (let loop ([xs xs][parent-attrs #false])
+    (for ([x (in-list xs)]
+          #:when (quad? x))
+         (define attrs (quad-attrs x))
+         (unless (set-member? attrs-seen attrs)
+           (if wants-parent-attrs? (proc attrs parent-attrs) (proc attrs))
+           (set-add! attrs-seen attrs))
+         (loop (quad-elems x) attrs))))
+
+(define (do-attr-iteration qs
+                           #:which-attr [which-attr 'all-attributes-signal]
+                           #:attr-proc attr-proc
+                           #:wants-parent-attrs [wants-parent-attrs? #false])
+  (define attr-predicate
+    (match which-attr
+      ['all-attributes-signal (λ (ak av) #true)]
+      [(? attr-key? attr-key) (λ (ak av) (eq? ak attr-key))]
+      [(? procedure? pred)
+       (if (eq? 1 (procedure-arity pred))
+           (λ (ak _) (pred ak)) ; 1 arity implies key-only test
+           pred)]
+      [other (raise-argument-error 'do-attr-iteration "key predicate" other)]))
+  (for-each-attrs qs
+                  (λ (attrs parent-attrs)
+                    ;; we don't iterate with `in-hash` (or `in-hash-keys`) because
+                    ;; `attrs` might get mutated during the loop,
+                    ;; which invalidates the reference `in-hash` is using
+                    (for* ([ak (in-list (hash-keys attrs))]
+                           [av (in-value (hash-ref attrs ak no-value-signal))]
+                           #:when (and (not (eq? av no-value-signal)) (attr-predicate ak av)))
+                          (match (if wants-parent-attrs?
+                                     (attr-proc ak av attrs parent-attrs)
+                                     (attr-proc ak av attrs))
+                            ;; void value: do nothing
+                            [(? void?) (void)]
+                            ;; otherwise treat return value as new attr value
+                            [new-av (hash-set! attrs ak new-av)])))))
+
+(define-pass (upgrade-attr-keys qs)
+  ;; convert attr keys from symbols to attr struct types
+  ;; also lets us validate keys strictly, if we want
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (define attr-lookup-table (for/hasheq ([a (in-list (current-attr-keys))])
+                                        (values (attr-key-name a) a)))
+  (define strict-attrs? (current-strict-attrs?))
+  (define (do-upgrade ak av attrs)
+    (cond
+      [(attr-key? ak) av]
+      [(symbol? ak)
+       (match (hash-ref attr-lookup-table ak :unknown-key)
+         [(== :unknown-key eq?) #:when strict-attrs?
+                                (raise-argument-error 'upgrade-attr-keys "known attr" ak)]
+         [attr-key
+          (hash-remove! attrs ak)
+          (hash-set! attrs attr-key av)])]
+      [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)]))
+  (do-attr-iteration qs #:attr-proc do-upgrade))
+
+(define-pass (set-top-level-attr-values qs)
+  ;; put the default values for mandatory keys at the top level
+  ;; so that when we linearize, they will percolate downward
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (define mandatory-attrs (for/hasheq ([ak (in-list (current-attr-keys))]
+                                       #:when (attr-key-mandatory? ak))
+                                      (values ak (attr-key-default ak))))
+  (list (make-quad #:attrs mandatory-attrs #:elems qs)))
+
+(define-pass (downcase-string-attr-values qs)
+  ;; make attribute values lowercase, unless they're case-sensitive
+  ;; so we can check them more easily later.
+  ;; in principle we could do this earlier and recursively process a single quad
+  ;; rather than linearized quads
+  ;; it would be faster because there are fewer copies of the attr hashes,
+  ;; so we do fewer tests
+  ;; but let's stay with the pipeline policy of operating on flat lists of quads
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (do-attr-iteration qs
+                     #:which-attr attr-cased-string-key?
+                     #:attr-proc (λ (ak av attrs) (string-downcase av))))
+
+
+(define-pass (convert-boolean-attr-values qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (do-attr-iteration qs
+                     #:which-attr attr-boolean-key?
+                     #:attr-proc (λ (ak av attrs)
+                                   (match av
+                                     [(? boolean?) av]
+                                     [(? string? str) #:when (equal? (string-downcase str) "false") #false]
+                                     [_ #true]))))
+
+(define-pass (convert-numeric-attr-values qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (do-attr-iteration qs
+                     #:which-attr attr-numeric-key?
+                     #:attr-proc (λ (ak av attrs)
+                                   (or (string->number av)
+                                       (raise-argument-error 'convert-numeric-attr-values "numeric string" av)))))
+
+(define-pass (convert-path-attr-values qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (do-attr-iteration qs
+                     #:which-attr attr-path-key?
+                     #:attr-proc (λ (ak av attrs)
+                                   (or (string->path av)
+                                       (raise-argument-error 'convert-path-attr-values "path string" av)))))
+
+(define-pass (convert-set-attr-values qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (do-attr-iteration qs
+                     #:which-attr attr-set-key?
+                     #:attr-proc (λ (ak av attrs)
+                                   (apply seteq (map string->symbol (string-split av))))))
+
+(module+ test
+  (let ([q (convert-set-attr-values (upgrade-attr-keys (bootstrap-input '(div ((font-features "calt")(font-features-add "")(font-features-subtract "swsh liga"))))))])
+    (check-equal? (quad-ref q :font-features) (seteq 'calt))
+    (check-equal? (quad-ref q :font-features-add) (seteq))
+    (check-equal? (quad-ref q :font-features-subtract) (seteq 'swsh 'liga))))
+
+
+(define-pass (complete-attr-paths qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  ;; convert every path value to a complete path
+  ;; so we don't get tripped up later by relative paths
+  ;; relies on `current-directory` being parameterized to source file's dir
+  (do-attr-iteration qs
+                     #:which-attr attr-path-key?
+                     #:attr-proc (λ (ak av attrs)
+                                   (unless (path? av)
+                                     (raise-argument-error 'complete-attr-paths "path" av))
+                                   (path->complete-path av))))
+
+
+(define-pass (parse-dimension-strings qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  ;; certain attributes can be "dimension strings", which are strings like "3in" or "4.2cm"
+  ;; we parse them into the equivalent measurement in points.
+  (do-attr-iteration qs
+                     #:which-attr attr-dimension-string-key?
+                     #:attr-proc (λ (ak av attrs) (parse-dimension av))))
+
+(module+ test
+  (define-attr-list debug-attrs
+    [:foo (make-attr-cased-string-key 'foo)]
+    [:ps (make-attr-path-key 'ps)]
+    [:dim (make-attr-dimension-string-key 'dim)]
+    [:boolt (make-attr-boolean-key 'boolt)]
+    [:boolf (make-attr-boolean-key 'boolf)]
+    [:num (make-attr-numeric-key 'num)]
+    [:num-def-42 (make-attr-numeric-key 'num-def-42 #true 42)])
+  (parameterize ([current-attr-keys debug-attrs])
+    (define (make-q) (make-quad #:attrs (list :foo "BAR"
+                                              'ding "dong"
+                                              :ps (string->path "file.txt")
+                                              :dim "2in"
+                                              :boolt "true"
+                                              :boolf "false"
+                                              :num "42.5")))
+    (define qs (list (make-q)))
+    (check-exn exn? (λ ()
+                      (parameterize ([current-strict-attrs? #true])
+                        (upgrade-attr-keys (list (make-q))))))
+    (check-not-exn (λ ()
+                     (parameterize ([current-strict-attrs? #false])
+                       (upgrade-attr-keys (list (make-q))))))
+    (check-equal? (quad-ref (car (set-top-level-attr-values (list (make-q)))) :num-def-42) 42)
+    (check-equal? (quad-ref (car (downcase-string-attr-values qs)) :foo) "bar")
+    (check-true (complete-path? (quad-ref (car (complete-attr-paths qs)) :ps)))
+    (check-equal? (quad-ref (car (parse-dimension-strings qs)) :dim) 144)
+    (let ([q (car (convert-boolean-attr-values qs))])
+      (check-true (quad-ref q :boolt))
+      (check-false (quad-ref q :boolf)))
+    (check-equal? (quad-ref (car (convert-numeric-attr-values qs)) :num) 42.5)))

quad2/attr.rkt

@@ -1,206 +1,34 @@
 #lang debug racket/base
-(require racket/match
-         racket/hash
-         racket/list
-         racket/string
-         racket/set
-         "dimension.rkt"
-         "pipeline.rkt"
+(require racket/list
          "struct.rkt"
-         "constants.rkt"
-         "quad.rkt"
-         "param.rkt")
+         "constants.rkt")
 (provide (all-defined-out))
 
-(module+ test
-  (require rackunit))
-
-(define (for-each-attrs xs proc)
-  ;; apply `proc` to each set of attrs in `xs`.
-  ;; recursively descend from top to bottom.
-  ;; but also track which attrs are visited and skip any already visited.
-  (define attrs-seen (mutable-seteq))
-  (define wants-parent-attrs? (= (procedure-arity proc) 2))
-  (let loop ([xs xs][parent-attrs #false])
-    (for ([x (in-list xs)]
-          #:when (quad? x))
-         (define attrs (quad-attrs x))
-         (unless (set-member? attrs-seen attrs)
-           (if wants-parent-attrs? (proc attrs parent-attrs) (proc attrs))
-           (set-add! attrs-seen attrs))
-         (loop (quad-elems x) attrs))))
-
-(define (do-attr-iteration qs
-                           #:which-attr [which-attr 'all-attributes-signal]
-                           #:attr-proc attr-proc
-                           #:wants-parent-attrs [wants-parent-attrs? #false])
-  (define attr-predicate
-    (match which-attr
-      ['all-attributes-signal (λ (ak av) #true)]
-      [(? attr-key? attr-key) (λ (ak av) (eq? ak attr-key))]
-      [(? procedure? pred)
-       (if (eq? 1 (procedure-arity pred))
-           (λ (ak _) (pred ak)) ; 1 arity implies key-only test
-           pred)]
-      [other (raise-argument-error 'do-attr-iteration "key predicate" other)]))
-  (for-each-attrs qs
-                  (λ (attrs parent-attrs)
-                    ;; we don't iterate with `in-hash` (or `in-hash-keys`) because
-                    ;; `attrs` might get mutated during the loop,
-                    ;; which invalidates the reference `in-hash` is using
-                    (for* ([ak (in-list (hash-keys attrs))]
-                           [av (in-value (hash-ref attrs ak no-value-signal))]
-                           #:when (and (not (eq? av no-value-signal)) (attr-predicate ak av)))
-                          (match (if wants-parent-attrs?
-                                     (attr-proc ak av attrs parent-attrs)
-                                     (attr-proc ak av attrs))
-                            ;; void value: do nothing
-                            [(? void?) (void)]
-                            ;; otherwise treat return value as new attr value
-                            [new-av (hash-set! attrs ak new-av)])))))
-
-(define-pass (upgrade-attr-keys qs)
-  ;; convert attr keys from symbols to attr struct types
-  ;; also lets us validate keys strictly, if we want
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  (define attr-lookup-table (for/hasheq ([a (in-list (current-attr-keys))])
-                                        (values (attr-key-name a) a)))
-  (define strict-attrs? (current-strict-attrs?))
-  (define (do-upgrade ak av attrs)
-    (cond
-      [(attr-key? ak) av]
-      [(symbol? ak)
-       (match (hash-ref attr-lookup-table ak :unknown-key)
-         [(== :unknown-key eq?) #:when strict-attrs?
-                                (raise-argument-error 'upgrade-attr-keys "known attr" ak)]
-         [attr-key
-          (hash-remove! attrs ak)
-          (hash-set! attrs attr-key av)])]
-      [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)]))
-  (do-attr-iteration qs #:attr-proc do-upgrade))
-
-(define-pass (set-top-level-attr-values qs)
-  ;; put the default values for mandatory keys at the top level
-  ;; so that when we linearize, they will percolate downward
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  (define mandatory-attrs (for/hasheq ([ak (in-list (current-attr-keys))]
-                                       #:when (attr-key-mandatory? ak))
-                                      (values ak (attr-key-default ak))))
-  (list (make-quad #:attrs mandatory-attrs #:elems qs)))
-
-(define-pass (downcase-string-attr-values qs)
-  ;; make attribute values lowercase, unless they're case-sensitive
-  ;; so we can check them more easily later.
-  ;; in principle we could do this earlier and recursively process a single quad
-  ;; rather than linearized quads
-  ;; it would be faster because there are fewer copies of the attr hashes,
-  ;; so we do fewer tests
-  ;; but let's stay with the pipeline policy of operating on flat lists of quads
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  (do-attr-iteration qs
-                     #:which-attr attr-cased-string-key?
-                     #:attr-proc (λ (ak av attrs) (string-downcase av))))
-
-
-(define-pass (convert-boolean-attr-values qs)
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  (do-attr-iteration qs
-                     #:which-attr attr-boolean-key?
-                     #:attr-proc (λ (ak av attrs)
-                                   (match av
-                                     [(? boolean?) av]
-                                     [(? string? str) #:when (equal? (string-downcase str) "false") #false]
-                                     [_ #true]))))
-
-(define-pass (convert-numeric-attr-values qs)
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  (do-attr-iteration qs
-                     #:which-attr attr-numeric-key?
-                     #:attr-proc (λ (ak av attrs)
-                                   (or (string->number av)
-                                       (raise-argument-error 'convert-numeric-attr-values "numeric string" av)))))
-
-(define-pass (convert-path-attr-values qs)
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  (do-attr-iteration qs
-                     #:which-attr attr-path-key?
-                     #:attr-proc (λ (ak av attrs)
-                                   (or (string->path av)
-                                       (raise-argument-error 'convert-path-attr-values "path string" av)))))
-
-(define-pass (convert-set-attr-values qs)
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  (do-attr-iteration qs
-                     #:which-attr attr-set-key?
-                     #:attr-proc (λ (ak av attrs)
-                                   (apply seteq (map string->symbol (string-split av))))))
-
-(module+ test
-  (let ([q (convert-set-attr-values (upgrade-attr-keys (bootstrap-input '(div ((font-features "calt")(font-features-add "")(font-features-subtract "swsh liga"))))))])
-    (check-equal? (quad-ref q :font-features) (seteq 'calt))
-    (check-equal? (quad-ref q :font-features-add) (seteq))
-    (check-equal? (quad-ref q :font-features-subtract) (seteq 'swsh 'liga))))
-
-
-(define-pass (complete-attr-paths qs)
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  ;; convert every path value to a complete path
-  ;; so we don't get tripped up later by relative paths
-  ;; relies on `current-directory` being parameterized to source file's dir
-  (do-attr-iteration qs
-                     #:which-attr attr-path-key?
-                     #:attr-proc (λ (ak av attrs)
-                                   (unless (path? av)
-                                     (raise-argument-error 'complete-attr-paths "path" av))
-                                   (path->complete-path av))))
-
-
-(define-pass (parse-dimension-strings qs)
-  #:pre (list-of quad?)
-  #:post (list-of quad?)
-  ;; certain attributes can be "dimension strings", which are strings like "3in" or "4.2cm"
-  ;; we parse them into the equivalent measurement in points.
-  (do-attr-iteration qs
-                     #:which-attr attr-dimension-string-key?
-                     #:attr-proc (λ (ak av attrs) (parse-dimension av))))
-
-(module+ test
-  (define-attr-list debug-attrs
-    [:foo (make-attr-cased-string-key 'foo)]
-    [:ps (make-attr-path-key 'ps)]
-    [:dim (make-attr-dimension-string-key 'dim)]
-    [:boolt (make-attr-boolean-key 'boolt)]
-    [:boolf (make-attr-boolean-key 'boolf)]
-    [:num (make-attr-numeric-key 'num)]
-    [:num-def-42 (make-attr-numeric-key 'num-def-42 #true 42)])
-  (parameterize ([current-attr-keys debug-attrs])
-    (define (make-q) (make-quad #:attrs (list :foo "BAR"
-                                              'ding "dong"
-                                              :ps (string->path "file.txt")
-                                              :dim "2in"
-                                              :boolt "true"
-                                              :boolf "false"
-                                              :num "42.5")))
-    (define qs (list (make-q)))
-    (check-exn exn? (λ ()
-                      (parameterize ([current-strict-attrs? #true])
-                        (upgrade-attr-keys (list (make-q))))))
-    (check-not-exn (λ ()
-                     (parameterize ([current-strict-attrs? #false])
-                       (upgrade-attr-keys (list (make-q))))))
-    (check-equal? (quad-ref (car (set-top-level-attr-values (list (make-q)))) :num-def-42) 42)
-    (check-equal? (quad-ref (car (downcase-string-attr-values qs)) :foo) "bar")
-    (check-true (complete-path? (quad-ref (car (complete-attr-paths qs)) :ps)))
-    (check-equal? (quad-ref (car (parse-dimension-strings qs)) :dim) 144)
-    (let ([q (car (convert-boolean-attr-values qs))])
-      (check-true (quad-ref q :boolt))
-      (check-false (quad-ref q :boolf)))
-    (check-equal? (quad-ref (car (convert-numeric-attr-values qs)) :num) 42.5)))
+(define-syntax-rule (define-attr-list LIST-NAME
+                      [ATTR-NAME ATTR-EXPR] ...)
+  (begin
+    (define ATTR-NAME ATTR-EXPR) ...
+    (define LIST-NAME
+      (let ([names (list ATTR-NAME ...)])
+        (cond
+          [(check-duplicates (map attr-key-name names))
+           =>
+           (λ (sym) (raise-user-error 'define-attr-list "duplicate attribute name: ~a" sym))]
+          [else names])))))
+
+(define-attr-list all-attr-keys
+  [:unknown-key (make-attr-unknown-key (gensym))]
+  [:font-family (make-attr-uncased-string-key 'font-family #true default-font-family)]
+  [:font-path (make-attr-path-key 'font-path)]
+  [:font-bold (make-attr-boolean-key 'font-bold #true #false)]
+  [:font-italic (make-attr-boolean-key 'font-italic #true #false)]
+  [:font-size (make-attr-dimension-string-key 'font-size #true default-font-size)]
+  [:font-features (make-attr-set-key 'font-features #true default-no-features)]
+  [:font-features-add (make-attr-set-key 'font-features-add #false default-no-features)]
+  [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)]
+
+  [:page-size (make-attr-uncased-string-key 'page-size #true default-page-size)]
+  [:page-orientation (make-attr-uncased-string-key 'page-orientation #true default-page-orientation)]
+  [:page-width (make-attr-dimension-string-key 'page-width)]
+  [:page-height (make-attr-dimension-string-key 'page-height)]
+  )

quad2/constants.rkt

@@ -1,7 +1,5 @@
 #lang racket/base
-(require racket/list
-         racket/set
-         "struct.rkt")
+(require racket/set)
 (provide (all-defined-out))
 
 (define default-font-family "text")
@@ -13,31 +11,3 @@
 (struct no-value ())
 (define no-value-signal (no-value))
 
-(define-syntax-rule (define-attr-list LIST-NAME
-                      [ATTR-NAME ATTR-EXPR] ...)
-  (begin
-    (define ATTR-NAME ATTR-EXPR) ...
-    (define LIST-NAME
-      (let ([names (list ATTR-NAME ...)])
-        (cond
-          [(check-duplicates (map attr-key-name names))
-           =>
-           (λ (sym) (raise-user-error 'define-attr-list "duplicate attribute name: ~a" sym))]
-          [else names])))))
-
-(define-attr-list all-attr-keys
-  [:unknown-key (make-attr-unknown-key (gensym))]
-  [:font-family (make-attr-uncased-string-key 'font-family #true default-font-family)]
-  [:font-path (make-attr-path-key 'font-path)]
-  [:font-bold (make-attr-boolean-key 'font-bold #true #false)]
-  [:font-italic (make-attr-boolean-key 'font-italic #true #false)]
-  [:font-size (make-attr-dimension-string-key 'font-size #true default-font-size)]
-  [:font-features (make-attr-set-key 'font-features #true default-no-features)]
-  [:font-features-add (make-attr-set-key 'font-features-add #false default-no-features)]
-  [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)]
-
-  [:page-size (make-attr-uncased-string-key 'page-size #true default-page-size)]
-  [:page-orientation (make-attr-uncased-string-key 'page-orientation #true default-page-orientation)]
-  [:page-width (make-attr-dimension-string-key 'page-width)]
-  [:page-height (make-attr-dimension-string-key 'page-height)]
-  )

quad2/draw.rkt

@@ -1,37 +1,36 @@
 #lang debug racket/base
-(require racket/list
-         racket/string
+(require racket/string
          racket/format
          racket/match
+         "attr.rkt"
          "quad.rkt"
          "pipeline.rkt"
-         "struct.rkt"
-         "layout.rkt"
-         "constants.rkt")
+         "struct.rkt")
 (provide (all-defined-out))
 
 (define-pass (make-drawing-insts qs)
-  #:pre (list-of has-position?)
+  ;; TODO: stronger precondition. but `has-position?` is too strong
+  #:pre (list-of quad?)
   #:post (list-of $drawing-inst?)
   (apply append
          (let ([current-font #false])
            (for/list ([q (in-list qs)])
-                     (cond
-                       [(eq? boq q) (list ($doc-start))]
-                       [(eq? eoq q) (list ($doc-end))]
-                       [(bop-quad? q) (list ($page-start (quad-ref q :page-width) (quad-ref q :page-height)))]
-                       [(eop-quad? q) (list ($page-end))]
-                       [(quad? q)
-                        (append
-                         (match (quad-ref q :font-path)
-                           [(== current-font) null]
-                           [font-path
-                            (set! current-font font-path)
-                            (list ($font font-path))])
-                         (if (pair? (quad-elems q))
-                             (list ($move (quad-origin q)) ($text (char->integer (car (string->list (car (quad-elems q)))))))
-                             null))]
-                       [else (raise-argument-error 'make-drawing-insts "known thing" q)])))))
+             (cond
+               [(eq? bod q) (list ($doc-start))]
+               [(eq? eod q) (list ($doc-end))]
+               [(bop-quad? q) (list ($page-start (quad-ref q :page-width) (quad-ref q :page-height)))]
+               [(eop-quad? q) (list ($page-end))]
+               [(quad? q)
+                (append
+                 (match (quad-ref q :font-path)
+                   [(== current-font) null]
+                   [font-path
+                    (set! current-font font-path)
+                    (list ($font font-path))])
+                 (if (pair? (quad-elems q))
+                     (list ($move (quad-origin q)) ($text (char->integer (car (string->list (car (quad-elems q)))))))
+                     null))]
+               [else (raise-argument-error 'make-drawing-insts "known thing" q)])))))
 
 (define valid-tokens '(doc-start doc-end page-start page-end text move set-font))
 
@@ -43,14 +42,14 @@
   (define ymax (if (pair? move-points) (add1 (apply max (map $point-y move-points))) 0))
   (string-join
    (for/list ([x (in-list xs)])
-             (string-join (map ~a (match x
-                                    ;; TODO: embed these code-generating functions
-                                    ;; as properties of the structs
-                                    [($move ($point x y)) (list y x 'move)]
-                                    [($text charint) (list charint 'text)]
-                                    [($font path-string) (list path-string 'set-font)]
-                                    [($doc-start) '(doc-start)]
-                                    [($doc-end) '(doc-end)]
-                                    [($page-start width height) (list height width 'page-start)]
-                                    [($page-end) '(page-end)]
-                                    [_ (error 'unknown-drawing-inst)])) " ")) "\n"))
+     (string-join (map ~a (match x
+                            ;; TODO: embed these code-generating functions
+                            ;; as properties of the structs
+                            [($move ($point x y)) (list y x 'move)]
+                            [($text charint) (list charint 'text)]
+                            [($font path-string) (list path-string 'set-font)]
+                            [($doc-start) '(doc-start)]
+                            [($doc-end) '(doc-end)]
+                            [($page-start width height) (list height width 'page-start)]
+                            [($page-end) '(page-end)]
+                            [_ (error 'unknown-drawing-inst)])) " ")) "\n"))

quad2/font.rkt

@@ -5,31 +5,32 @@
          racket/list
          racket/set
          racket/string
-         fontland/font-path
+         "attr.rkt"
          "quad.rkt"
          "constants.rkt"
          "pipeline.rkt"
          "param.rkt"
          "struct.rkt"
-         "dimension.rkt"
-         "attr.rkt"
+         "attr-passes.rkt"
          "glyphrun.rkt"
-         (prefix-in unicode: (combine-in "unicode/emoji.rkt" "unicode/math.rkt")))
+         (prefix-in unicode: (combine-in "unicode/emoji.rkt")))
 (provide (all-defined-out))
 
 (define-runtime-path quad2-fonts-dir "default-fonts")
-(define-runtime-path default-font-face "default-fonts/default/SourceSerifPro-Regular.otf")
+(define-runtime-path default-font-face "default-fonts/default/regular/SourceSerif4-Regular.otf")
+(define-runtime-path default-font-face-b "default-fonts/default/bold/SourceSerif4-Bold.otf")
+(define-runtime-path default-font-face-i "default-fonts/default/italic/SourceSerif4-It.otf")
+(define-runtime-path default-font-face-bi "default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf")
 (define-runtime-path default-math-face "default-fonts/fallback-math/NotoSansMath-Regular.ttf")
 (define-runtime-path default-emoji-face "default-fonts/fallback-emoji/NotoEmoji-Regular.ttf")
 (define top-font-directory "fonts")
 (define base-extensions '(".otf" ".ttf" ".woff" ".woff2"))
 (define font-file-extensions (map string->bytes/utf-8 (append base-extensions (map string-upcase base-extensions))))
 
-
 (define (fonts-in-directory dir)
   (for/list ([font-path (in-directory dir)]
              #:when (member (path-get-extension font-path) font-file-extensions))
-            font-path))
+    font-path))
 
 (define (setup-font-path-table [base-path (current-directory)])
   ;; create a table of font paths that we can use to resolve references to font names.
@@ -51,47 +52,51 @@
          #:when (directory-exists? font-family-subdir)
          [fonts-in-this-directory (in-value (fonts-in-directory font-family-subdir))]
          [font-path (in-list fonts-in-this-directory)])
-        (match-define (list font-path-string family-name)
-          (for/list ([x (list font-path font-family-subdir)])
-                    (path->string (find-relative-path fonts-dir x))))
-        (define path-parts (for/list ([part (in-list (explode-path (string->path (string-downcase font-path-string))))])
-                                     (path->string part)))
-        (define key
-          (cons (string-downcase family-name)
-                (cond
-                  ;; special case: if there's only one style in the family directory,
-                  ;; treat it as the regular style, regardless of name
-                  [(= (length fonts-in-this-directory) 1) 'r]
-                  ;; cases where fonts are in subdirectories named by style
-                  ;; infer style from subdir name
-                  [(and (member "bold" path-parts) (member "italic" path-parts)) 'bi]
-                  [(member "bold" path-parts) 'b]
-                  [(member "italic" path-parts) 'i]
-                  [else
-                   ;; try to infer from filename alone
-                   ;; TODO: what happens when there is no regular style?
-                   (define filename (string-downcase (last path-parts)))
-                   (define filename-contains-bold? (string-contains? filename "bold"))
-                   (define filename-contains-italic? (string-contains? filename "italic"))
-                   (cond
-                     [(and filename-contains-bold? filename-contains-italic?) 'bi]
-                     [filename-contains-bold? 'b]
-                     [filename-contains-italic? 'i]
-                     [else 'r])])))
-        ;; only set value if there's not one there already.
-        ;; this means that we only use the first eligible font we find.
-        (hash-ref! font-paths key font-path))
+    (match-define (list font-path-string family-name)
+      (for/list ([x (list font-path font-family-subdir)])
+        (path->string (find-relative-path fonts-dir x))))
+    (define path-parts (for/list ([part (in-list (explode-path (string->path (string-downcase font-path-string))))])
+                         (path->string part)))
+    (define key
+      (cons (string-downcase family-name)
+            (cond
+              ;; special case: if there's only one style in the family directory,
+              ;; treat it as the regular style, regardless of name
+              [(= (length fonts-in-this-directory) 1) 'r]
+              ;; cases where fonts are in subdirectories named by style
+              ;; infer style from subdir name
+              [(and (member "bold" path-parts) (member "italic" path-parts)) 'bi]
+              [(member "bold" path-parts) 'b]
+              [(member "italic" path-parts) 'i]
+              [else
+               ;; try to infer from filename alone
+               ;; TODO: what happens when there is no regular style?
+               (define filename (string-downcase (last path-parts)))
+               (define filename-contains-bold? (string-contains? filename "bold"))
+               (define filename-contains-italic? (string-contains? filename "italic"))
+               (cond
+                 [(and filename-contains-bold? filename-contains-italic?) 'bi]
+                 [filename-contains-bold? 'b]
+                 [filename-contains-italic? 'i]
+                 [else 'r])])))
+    ;; only set value if there's not one there already.
+    ;; this means that we only use the first eligible font we find.
+    (hash-ref! font-paths key font-path))
   font-paths)
 
 (define (make-key font-family [bold #f] [italic #f])
-  (cons (string-downcase font-family)
-        (cond
-          [(and bold italic) 'bi]
-          [bold 'b]
-          [italic 'i]
-          [else 'r])))
+  (and font-family
+       (cons (string-downcase font-family)
+             (cond
+               [(and bold italic) 'bi]
+               [bold 'b]
+               [italic 'i]
+               [else 'r]))))
 
-(define (font-attrs->path font-paths font-family bold italic)
+(define (font-attrs->path font-paths
+                          #:family font-family
+                          #:bold bold
+                          #:italic italic)
   ;; find the font-path corresponding to a certain family name and style.
   (define regular-key (make-key font-family))
   
@@ -106,14 +111,17 @@
       (display "(fontconfig lookup unimplemented)")
       #;(for* ([bold (in-list (list #false #true))]
                [italic (in-list (list #false #true))])
-              (hash-set! font-paths
-                         (make-key font-family bold italic)
-                         (family->path font-family #:bold bold #:italic italic))))
+          (hash-set! font-paths
+                     (make-key font-family bold italic)
+                     (family->path font-family #:bold bold #:italic italic))))
   (cond
     [(hash-ref font-paths (make-key font-family bold italic) #false)]
     ;; try regular style if style-specific key isn't there for b i or bi
     [(and (or bold italic) (hash-ref font-paths regular-key #false))]
     ;; otherwise use default
+    [(and bold italic) default-font-face-bi]
+    [bold default-font-face-b]
+    [italic default-font-face-i]
     [else default-font-face]))
 
 (define (font-path-string? x)
@@ -121,38 +129,46 @@
        (member (path-get-extension (string->path x)) font-file-extensions)
        #true))
 
+(define font-family-attr-keys (list :font-family :font-bold :font-italic))
 
+(define (quad-without-font-family-attrs? x)
+  (and (quad? x) (for/and ([ak (in-list font-family-attr-keys)])
+                   (not (quad-ref x ak #false)))))
 
 (define-pass (resolve-font-paths qs)
   ;; convert references to a font family and style to an font path on disk
   ;; we trust it exists because we used `setup-font-path-table!` earlier,
   ;; but if not, fallback fonts will kick in, on the idea that a missing font shouldn't stop the show
   #:pre (list-of quad?)
-  #:post (list-of quad?)
+  ;; once we have a font path we don't need the family, bold, or italic keys
+  ;; because they just exist to help select a font path
+  #:post (list-of quad-without-font-family-attrs?)
   (define font-paths (setup-font-path-table))
 
-  (define (resolve-font-path font-paths attrs)
+  (define (resolve-font-path attrs)
     ;; convert references to a font family and style to an font path on disk
     ;; we trust it exists because we used `setup-font-path-table` earlier,
     ;; but if not, fallback fonts will kick in, on the idea that a missing font shouldn't stop the show
     ;; we know we have :font-family because this pass is restricted to that key
-    (match (hash-ref attrs :font-family)
-      [(? font-path-string? ps) (path->complete-path ps)]
-      [this-font-family
-       (define this-bold (hash-ref attrs :font-bold (λ () (error 'need-default-font-bold))))
-       (define this-italic (hash-ref attrs :font-italic (λ () (error 'need-default-font-italic))))
-       (font-attrs->path font-paths this-font-family this-bold this-italic)]))
+    (hash-ref! attrs :font-path
+               (λ ()
+                 (font-attrs->path font-paths
+                                   #:family (hash-ref attrs :font-family #false)
+                                   #:bold (hash-ref attrs :font-bold #false)
+                                   #:italic (hash-ref attrs :font-italic #false))))
+    (for ([key font-family-attr-keys])
+      (hash-remove! attrs key)))
   
-  (do-attr-iteration qs
-                     #:which-attr :font-family
-                     #:attr-proc (λ (_ __ attrs) (resolve-font-path font-paths attrs))))
+  (for-each-attrs qs resolve-font-path))
 
 (define (resolved-font-for-family val #:bold [bold #f] #:italic [italic #f])
-  (define qs (list (make-quad #:attrs (make-hasheq
-                                       (list (cons :font-family (string-downcase val))
-                                             (cons :font-bold bold)
-                                             (cons :font-italic italic))))))
-  (last (explode-path (quad-ref (car (resolve-font-paths qs)) :font-family))))
+  (define qs (list (make-quad
+                    #:attrs (make-hasheq
+                             (list (cons :font-family (string-downcase val))
+                                   (cons :font-bold bold)
+                                   (cons :font-italic italic)))
+                    #:elems null)))
+  (last (explode-path (quad-ref (car (resolve-font-paths qs)) :font-path))))
 
 (define (parse-em pstr)
   (define em-suffix "em")
@@ -194,7 +210,9 @@
     (check-equal? (resolved-font-for-family "Heading") (build-path "fira-sans-light.otf"))
     (check-equal? (resolved-font-for-family "CODE") (build-path "fira-mono.otf"))
     (check-equal? (resolved-font-for-family "blockquote" #:bold #t) (build-path "fira-sans-bold.otf"))
-    (check-equal? (resolved-font-for-family "nonexistent-fam") (build-path "SourceSerifPro-Regular.otf")))
+    (check-equal? (resolved-font-for-family "nonexistent-fam") (build-path "SourceSerif4-Regular.otf"))
+    (check-equal? (resolved-font-for-family "nonexistent-fam" #:italic #t) (build-path "SourceSerif4-It.otf"))
+    (check-equal? (resolved-font-for-family "nonexistent-fam" #:bold #t #:italic #t) (build-path "SourceSerif4-BoldIt.otf")))
 
   (define qs (bootstrap-input
               (make-quad #:tag 'div
@@ -202,7 +220,8 @@
                          #:elems (list (make-quad #:tag 'span
                                                   #:attrs (make-hasheq (list (cons :font-size "1.5em")))
                                                   #:elems (list (make-quad #:tag 'span
-                                                                           #:attrs (make-hasheq (list (cons :font-size "200%"))))))))))
+                                                                           #:attrs (make-hasheq (list (cons :font-size "200%")))
+                                                                           #:elems null)))))))
   (check-equal? (quad-ref (quad-elems (car (resolve-font-sizes (parse-dimension-strings qs)))) :font-size) 150))
 
 
@@ -212,11 +231,11 @@
   #:pre (list-of quad?)
   #:post (λ (qs)
            (for/and ([q (in-list qs)])
-                    (define attrs (quad-attrs q))
-                    (and
-                     (hash-has-key? attrs :font-features)
-                     (not (hash-has-key? attrs :font-features-add))
-                     (not (hash-has-key? attrs :font-features-subtract)))))
+             (define attrs (quad-attrs q))
+             (and
+              (hash-has-key? attrs :font-features)
+              (not (hash-has-key? attrs :font-features-add))
+              (not (hash-has-key? attrs :font-features-subtract)))))
 
   (define (resolve-font-features-once attrs parent-attrs)
     ;; if attrs already has an explicit :font-features key, we don't need to calculate it
@@ -248,7 +267,8 @@
                                                                        (cons :font-features-add "swsh")
                                                                        (cons :font-features-subtract "liga")))
                                                  #:elems (list (make-quad #:tag 'span
-                                                                          #:attrs (make-hasheq (list (cons :font-features "hist")))))))))])
+                                                                          #:attrs (make-hasheq (list (cons :font-features "hist")))
+                                                                          #:elems null))))))])
     (define q (car (resolve-font-features (convert-set-attr-values (upgrade-attr-keys qs)))))
     (check-equal? (quad-ref q :font-features) (seteq 'ss01 'liga))
     (check-equal? (quad-ref (car (quad-elems q)) :font-features) (seteq 'ss01 'swsh))
@@ -267,7 +287,7 @@
   #:pre (list-of quad?)
   #:post (list-of simple-quad-with-font-path-key?)
   (for ([q (in-list qs)])
-       (quad-ref! q :font-path #false)))
+    (quad-ref! q :font-path #false)))
 
 (define-pass (remove-font-without-char qs)
   ;; at this point we have a font-path value for each character
@@ -281,7 +301,7 @@
          [font-path (in-value (quad-ref q :font-path))]
          #:when font-path
          #:unless (char-in-font? font-path (car (quad-elems q))))
-        (quad-set! q :font-path #false)))
+    (quad-set! q :font-path #false)))
 
 (define (simple-quad-with-complete-font-path? q)
   (and (simple-quad? q) (complete-path? (quad-ref q :font-path))))
@@ -292,18 +312,18 @@
   #:pre (list-of simple-quad-with-font-path-key?)
   #:post (list-of simple-quad-with-complete-font-path?)
   (for ([q (in-list qs)])
-       (quad-update! q :font-path (λ (val)
-                                    (or
-                                     val
-                                     (match (quad-elems q)
-                                       [(cons (? string? str) _)
-                                        (match (string-ref str 0)
-                                          ;; TODO: how to determine fallback priority for alphabetic chars?
-                                          ;; they are all `math?`
-                                          ;; for now we will use math face for everything that's not emoji
-                                          ;; later: test default-font-face to see if it contains the char,
-                                          ;; and if not, use math
-                                          [(? unicode:emoji? c) default-emoji-face]
-                                          #;[(? unicode:math? c) default-math-face]
-                                          [_ default-math-face])]
-                                       [_ default-math-face]))))))
+    (quad-update! q :font-path (λ (val)
+                                 (or
+                                  val
+                                  (match (quad-elems q)
+                                    [(cons (? string? str) _)
+                                     (match (string-ref str 0)
+                                       ;; TODO: how to determine fallback priority for alphabetic chars?
+                                       ;; they are all `math?`
+                                       ;; for now we will use math face for everything that's not emoji
+                                       ;; later: test default-font-face to see if it contains the char,
+                                       ;; and if not, use math
+                                       [(? unicode:emoji? c) default-emoji-face]
+                                       #;[(? unicode:math? c) default-math-face]
+                                       [_ default-math-face])]
+                                    [_ default-math-face]))))))

quad2/layout.rkt

@@ -8,14 +8,6 @@
   ($point? $size? . -> . $point?)
   ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1))))
 
-(define/contract (size q)
-  (quad? . -> . $size?)
-  (quad-size q))
-
-(define/contract (advance q)
-  (quad? . -> . $size?)
-  (quad-size q))
-
 (define (min-x rect) ($point-x ($rect-origin rect)))
 (define (width rect) ($size-width ($rect-size rect)))
 (define (max-x rect) (+ (min-x rect) (width rect)))
@@ -49,22 +41,29 @@
   (set-quad-size! q ($size (length (or (quad-elems q) null)) 0))
   q)
 
+(define (has-size? x)
+  (and (quad? x) (quad-size x)))
+
 (define-pass (layout qs)
-  #:pre (list-of has-no-position?)
-  #:post (list-of has-position?)
+  ;; TODO: stronger pre & postcondition.
+  ;; but `has-size?` is too strong for precondition,
+  ;; and `has-position?` is too strong for postcondition.
+  ;; because we need to preserve signals like bop and eop
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
   (define frame ($rect ($point 0 0) ($size (current-wrap-width) 30)))
   (define (quad-fits? q posn)
-    (rect-contains-rect? frame ($rect posn (size q))))
+    (rect-contains-rect? frame ($rect posn (quad-size q))))
   (for/fold ([posn0 ($point 0 0)]
-             #:result (filter has-position? qs))
-            ([q (in-list (map make-debug-size qs))]
+             #:result qs)
+            ([q (in-list qs)]
              #:when (quad-size q))
     (define first-posn-on-next-line ($point 0 (add1 ($point-y posn0))))
     (define other-possible-posns (list first-posn-on-next-line))
     (define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))]
                               #:when (quad-fits? q posn))
-                             posn))
+                    posn))
     (unless posn1
       (error 'no-posn-that-fits))
     (set-quad-origin! q posn1)
-    (posn-add posn1 (advance q))))
+    (posn-add posn1 ($size ($size-width (quad-size q)) 0))))

quad2/linearize.rkt

@@ -38,7 +38,13 @@
                                             [else (list (mq (list e)))])))])))))
 
 (module+ test
-  (define q (make-quad #:attrs (hasheq 'foo 42) #:elems (list (make-quad #:elems (list "Hi" "    idiot" (make-quad #:attrs (hasheq 'bar 84) #:elems '("There")) " Eve" "ry" "one" (make-quad #:attrs (hasheq 'zam 108) #:elems null))))))
+  (define q (make-quad #:attrs (hasheq 'foo 42)
+                       #:elems (list (make-quad
+                                      #:attrs (make-hasheq)
+                                      #:elems (list "Hi" "    idiot"
+                                                    (make-quad #:attrs (hasheq 'bar 84)
+                                                               #:elems '("There")) " Eve" "ry" "one" (make-quad #:attrs (hasheq 'zam 108)
+                                                                                                                #:elems null))))))
   (define lqs (linearize (list q)))
   lqs)
 
@@ -115,18 +121,12 @@
            (unless (eop-quad? (last qs))
              (error 'not-an-eop-quad))
            ((list-of simple-quad?) (drop-right (cdr qs) 1)))
-  (define bop (bop-quad))
-  (define eop (eop-quad))
-  (set-quad-attrs! bop (quad-attrs (first qs)))
-  (set-quad-attrs! eop (quad-attrs (last qs)))
-  (append (list bop) qs (list eop)))
+ (insert-at-end (insert-at-beginning qs (bop-quad)) (eop-quad)))
 
-(define-pass (append-boq-and-eoq qs)
+(define-pass (append-bod-and-eod qs)
   ;; attach the boq and eoq signals
   #:pre (list-of simple-quad?)
   #:post (λ (qs) (match qs
-                   [(list (== boq) (? simple-quad?) ... (== eoq)) #true]
+                   [(list (== bod) (? simple-quad?) ... (== eod)) #true]
                    [_ #false]))
-  (set-quad-attrs! boq (quad-attrs (first qs)))
-  (set-quad-attrs! eoq (quad-attrs (last qs)))
-  (append (list boq) qs (list eoq)))
+  (insert-at-end (insert-at-beginning qs bod) eod))

quad2/main.rkt

@@ -6,19 +6,24 @@
          "layout.rkt"
          "draw.rkt"
          "attr.rkt"
+         "quad-passes.rkt"
+         "attr-passes.rkt"
          "font.rkt"
          "constants.rkt"
          "param.rkt"
          "page.rkt"
-         racket/list
-         racket/match
-         racket/file)
+         "text.rkt"
+         racket/match)
 
 (define quad-compile
   (make-pipeline
    ;; each pass in the pipeline is at least
    ;; (list-of quad?) -> (list-of quad?)
-                  
+
+   ;; quad prep ==============
+   install-default-attrs
+   install-default-elems
+   
    ;; attribute prep =============
    ;; all attrs start out as symbol-string pairs.
    ;; we convert keys & values to corresponding higher-level types.
@@ -37,9 +42,6 @@
    parse-dimension-strings
    resolve-font-sizes
    resolve-font-features
-   parse-page-sizes
-   resolve-font-paths
-   complete-attr-paths
 
    ;; linearization =============
    ;; we postpone this step until we're certain any
@@ -50,6 +52,11 @@
    linearize
    
    ;; post-linearization resolutions & parsings ============= 
+   parse-page-sizes
+   print-pass
+   resolve-font-paths
+   print-pass
+   complete-attr-paths
    mark-text-runs
    merge-adjacent-strings
    split-whitespace
@@ -58,7 +65,8 @@
    remove-font-without-char
    insert-fallback-font
    append-bop-and-eop
-   append-boq-and-eoq
+   append-bod-and-eod
+   measure-text-runs
    layout
    make-drawing-insts
    stackify))
@@ -76,9 +84,9 @@
                    [current-use-postconditions? #t])
       (quad-compile (bootstrap-input x))))
 
-  (match (test-compile "WHO")
+  (match (test-compile "Whomever")
     [(? string? insts)
-     (displayln insts)
+     #;(displayln insts)
      #;(render insts #:using text-renderer)
      #;(render insts #:using drr-renderer)
      (render insts #:using (html-renderer (build-path (find-system-path 'desk-dir) "test.html")))

quad2/page.rkt

@@ -1,6 +1,7 @@
 #lang debug racket/base
 (require "quad.rkt"
          "attr.rkt"
+         "attr-passes.rkt"
          "pipeline.rkt"
          "constants.rkt"
          "param.rkt"

quad2/param.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/match
          "constants.rkt"
+         "attr.rkt"
          "struct.rkt")
 (provide (all-defined-out))
 

quad2/pipeline.rkt

@@ -6,6 +6,16 @@
          "quad.rkt")
 (provide (all-defined-out))
 
+(define (list-of proc)
+  (λ (x)
+    (and (list? x)
+         (for/and ([xi (in-list x)])
+           (or (proc xi)
+               (let ([procname (object-name proc)])
+                 (raise-argument-error
+                  (string->symbol (format "list-of ~a" procname))
+                  (symbol->string procname) xi)))))))
+
 (struct pipeline (passes)
   #:guard (λ (procs name)
             (unless ((list-of procedure?) procs)
@@ -48,7 +58,7 @@
                    (define failure-msg (format "~a pass (as precondition)" 'PASS-NAME))
                    (with-handlers ([exn:fail:contract? (make-failure-handler failure-msg)])
                      (unless (PRECOND-PROC ARG)
-                       (raise-argument-error 'PASS-NAME (symbol->string 'PRECOND-PROC) ARG))))
+                       (raise-argument-error 'PASS-NAME (format "~a" 'PRECOND-PROC) ARG))))
                  ;; a pass can be functional or mutational.
                  ;; if it returns void, assume mutational
                  ;; and return the input item.
@@ -61,7 +71,7 @@
                      (define failure-msg (format "~a pass (as postcondition)" 'PASS-NAME))
                      (with-handlers ([exn:fail:contract? (make-failure-handler failure-msg)])
                        (unless (POSTCOND-PROC res)
-                         (raise-argument-error 'PASS-NAME (symbol->string 'POSTCOND-PROC) ARG)))))))
+                         (raise-argument-error 'PASS-NAME (format "~a" 'POSTCOND-PROC) ARG)))))))
            'PASS-NAME)))]))
 
 (define-pass (print-pass qs)

quad2/quad-passes.rkt

@@ -0,0 +1,26 @@
+#lang debug racket/base
+(require "pipeline.rkt"
+         "quad.rkt")
+(provide (all-defined-out))
+
+(define (quad-with-attrs? x)
+  (and (quad? x) (quad-attrs x)))
+
+(define-pass (install-default-attrs qs)
+  ;; make sure attrs are not #false
+  #:pre (list-of quad?)
+  #:post (list-of quad-with-attrs?)
+  (for ([q (in-list qs)]
+        #:unless (quad-attrs q))
+    (set-quad-attrs! q (make-hasheq))))
+
+(define (quad-with-elems? x)
+  (and (quad? x) (quad-elems x)))
+
+(define-pass (install-default-elems qs)
+  ;; ensure elems are not #false
+  #:pre (list-of quad?)
+  #:post (list-of quad-with-elems?)
+  (for ([q (in-list qs)]
+        #:unless (quad-elems q))
+    (set-quad-elems! q null)))

quad2/quad.rkt

@@ -18,16 +18,6 @@
 (define current-wrap-width (make-parameter 5))
 (define current-page-size (make-parameter ($size 10 10)))
 
-(define (list-of proc)
-  (λ (x)
-    (and (list? x)
-         (for/and ([xi (in-list x)])
-                  (or (proc xi)
-                      (let ([procname (object-name proc)])
-                        (raise-argument-error
-                         (string->symbol (format "list-of ~a" procname))
-                         (symbol->string procname) xi)))))))
-
 (define-syntax-rule (auto-struct NAME (FIELD ...) . ARGS)
   (struct NAME (FIELD ...) . ARGS))
 
@@ -36,11 +26,10 @@
              #:constructor-name quad-new
              #:methods gen:custom-write
              [(define (write-proc val out mode)
-                (let* ([fields (filter-map (λ (f) (f val)) (list quad-tag quad-attrs quad-elems quad-origin quad-size))]
-                       [fields (if (null? fields) (list #f) fields)])
-                  (fprintf out (format "<~a ~a>"
-                                       (or (car fields) "quad")
-                                       (string-join (map ~v (cdr fields)) " ")))))])
+                ;; cdr because struct->vector puts struct descriptor in first slot
+                (define fields (cdr (vector->list (struct->vector val))))
+                ;; cdr because tag is in first position
+                (fprintf out (format "<~a>" (string-join (cons (~a (or (quad-tag val) "quad")) (map ~v (filter values (cdr fields)))) " "))))])
 
 (define (quad-new-default)
   (apply quad-new (make-list (procedure-arity quad-new) #f)))
@@ -63,8 +52,8 @@
 (define (quad-elems? x) (list? x))
 
 (define/contract (make-quad #:tag [tag #false]
-                            #:attrs [attrs (make-quad-attrs null)]
-                            #:elems [elems null])
+                            #:attrs [attrs #f]
+                            #:elems [elems #f])
   (() (#:tag quad-tag? #:attrs (or/c quad-attrs? (listof any/c)) #:elems quad-elems?) . ->* . quad?)
   (let ([attrs (let loop ([attrs attrs])
                  (cond
@@ -147,9 +136,31 @@
 (module+ test
   (define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine"))))
 
-(define boq (make-quad #:tag 'boq-quad))
-(define eoq (make-quad #:tag 'eoq-quad))
+(define bod (make-quad #:tag 'bod-quad))
+(define eod (make-quad #:tag 'eod-quad))
 (define (bop-quad) (make-quad #:tag 'bop-quad))
 (define (bop-quad? x) (and (quad? x) (eq? (quad-tag x) 'bop-quad)))
 (define (eop-quad) (make-quad #:tag 'eop-quad))
 (define (eop-quad? x) (and (quad? x) (eq? (quad-tag x) 'eop-quad)))
+
+(define (insert-at-beginning qs x)
+  (unless (andmap quad? qs)
+    (raise-argument-error 'insert-at-beginning "list of quads" qs))
+  (unless (quad? x)
+    (raise-argument-error 'insert-at-beginning "quad" x))
+  (cond
+    [(pair? qs)
+     (set-quad-attrs! x (quad-attrs (first qs)))
+     (cons x qs)]
+    [else (list x)]))
+
+(define (insert-at-end qs x)
+  (unless (andmap quad? qs)
+    (raise-argument-error 'insert-at-end "list of quads" qs))
+  (unless (quad? x)
+    (raise-argument-error 'insert-at-end "quad" x))
+  (cond
+    [(pair? qs)
+     (set-quad-attrs! x (quad-attrs (last qs)))
+     (append qs (list x))]
+    [else (list x)]))

quad2/render.rkt

@@ -5,16 +5,54 @@
          txexpr)
 (provide (all-defined-out))
 
-(struct $renderer (doc-start-func
-                   doc-end-func
-                   page-start-func
-                   page-end-func
-                   text-func
-                   set-font-func
-                   move-func
-                   return-func) #:transparent)
+(module inner racket/base
+  (provide (all-defined-out))
+  (struct $renderer (doc-start-func
+                     doc-end-func
+                     page-start-func
+                     page-end-func
+                     text-func
+                     set-font-func
+                     move-func
+                     return-func) #:transparent)
 
-(define current-renderer (make-parameter ($renderer void void void void void void void void)))
+  (define-syntax-rule (check-arity PROCNAME [PROC ARITY] ...)
+    (begin
+      (unless (or (eq? (procedure-arity PROC) ARITY) (equal? void PROC))
+        (raise-argument-error PROCNAME (format "procedure of arity ~a for ~a" ARITY 'PROC) PROC)) ...))
+
+  (define (make-renderer
+           #:doc-start-func [doc-start-func void]
+           #:doc-end-func [doc-end-func void]
+           #:page-start-func [page-start-func void]
+           #:page-end-func [page-end-func void]
+           #:text-func [text-func void]
+           #:set-font-func [set-font-func void]
+           #:move-func [move-func void]
+           #:return-func [return-func void])
+    (check-arity 'make-renderer
+                 [doc-start-func 0]
+                 [doc-end-func 0]
+                 [page-start-func 2]
+                 [page-end-func 0]
+                 [text-func 1]
+                 [set-font-func 1]
+                 [move-func 2]
+                 [return-func 0])
+    ($renderer doc-start-func
+               doc-end-func
+               page-start-func
+               page-end-func
+               text-func
+               set-font-func
+               move-func
+               return-func)))
+
+(require 'inner)
+
+(define null-renderer (make-renderer))
+
+(define current-renderer (make-parameter null-renderer))
 
 (define text-renderer
   ;; scan over the instructions and record where the chars want to go
@@ -23,28 +61,27 @@
         [xmax 0]
         [ymax 0]
         [results null])
-    ($renderer
-     void
-     void
+    (make-renderer
+     #:page-start-func
      (λ (width height)
        (set! xmax width)
        (set! ymax height))
+     #:page-end-func
      (λ ()
        ;; fill in a character grid
        (define str (string-join
                     (for/list ([y (in-range ymax)])
-                              (list->string
-                               (map integer->char
-                                    (for/list ([x (in-range xmax)])
-                                              (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n"))
+                      (list->string
+                       (map integer->char
+                            (for/list ([x (in-range xmax)])
+                              (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n"))
        (set! results (cons str results)))
-     (λ (str) (hash-set! char-pos-table current-loc str))
-     void
-     (λ (x y) (set! current-loc (make-rectangular x y)))
-     (λ ()
-       #;(unless (pair? results)
-           (error 'text-renderer-failed))
-       (for-each displayln results)))))
+     #:text-func (λ (str) (hash-set! char-pos-table current-loc str))
+     #:move-func (λ (x y) (set! current-loc (make-rectangular x y)))
+     #:return-func (λ ()
+                     #;(unless (pair? results)
+                         (error 'text-renderer-failed))
+                     (for-each displayln results)))))
 
 (require racket/gui)
 
@@ -54,24 +91,22 @@
         [dc #f]
         [current-loc 0+0i]
         [current-font #false])
-    ($renderer
-     void
-     void
-     (let ([em-scale 30]
-           [my-face (match (get-face-list 'mono)
+    (make-renderer
+     #:page-start-func
+     (let ([my-face (match (get-face-list 'mono)
                       [(? null?) (error 'no-mono-font-available)]
                       [(cons face _) face])])
        (λ (width height)
-         (define target (make-bitmap (* em-scale width) (* em-scale height)))
+         (define target (make-bitmap width height))
          (set! targets (cons target targets))
          (set! dc (new bitmap-dc% [bitmap target]))
-         (send dc scale em-scale em-scale) 
          (send dc set-font (make-font #:size 1 #:face my-face))
          (send dc set-text-foreground "black")))
-     void
+     #:text-func
      (λ (charint)
        (when dc
          (send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc))))
+     #:set-font-func
      (λ (ps)
        ;; racket/draw can't load arbitrary user fonts from a path
        ;; https://github.com/racket/racket/issues/1348
@@ -80,36 +115,41 @@
        ;; but it would allow slightly more accurate rendering for contexts
        ;; that don't support fonts by path
        (log-quad2-warning (format "can't load font ~a" ps)))
+     #:move-func
      (λ (x y) (set! current-loc (make-rectangular x y)))
+     #:return-func
      (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets))))))
 
 (define (html-renderer html-file)
   (let ([xmax 0]
         [ymax 0]
-        [em-scale 30]
         [page-quads null]
         [current-loc 0+0i]
         [pages null]
         [fonts (make-hasheqv)]
         [current-font ""])
-    ($renderer
-     void
-     void
+    (make-renderer
+     #:page-start-func
      (λ (width height)
        (set! page-quads null)
        (set! xmax width)
        (set! ymax height))
+     #:page-end-func
      (λ ()
        (set! pages (cons `(div ((class "page")
                                 (style ,(format "position: relative;width:~apx;height:~apx;border:1px solid black;background:white" xmax ymax))) ,@(reverse page-quads)) pages))
        (set! page-quads null))
+     #:text-func
      (λ (charint)
        (set! page-quads (cons
-                         `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a" (* em-scale (real-part current-loc)) (* em-scale (imag-part current-loc)) current-font)))
+                         `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a;font-size:~apx" (real-part current-loc) (imag-part current-loc) current-font 12)))
                                ,(string (integer->char charint))) page-quads)))
+     #:set-font-func
      (λ (ps)
        (set! current-font (hash-ref! fonts ps (λ () (gensym 'font)))))
+     #:move-func
      (λ (x y) (set! current-loc (make-rectangular x y)))
+     #:return-func
      (λ ()
        (with-output-to-file html-file
          #:exists 'replace
@@ -120,27 +160,53 @@
                           (head (style ((type "text/css"))
                                        ,(string-join
                                          (for/list ([(ps fontsym) (in-hash fonts)])
-                                                   (format "@font-face { font-family: \"~a\";\nsrc: url(\"~a\");}" fontsym ps)))))
+                                           (format "@font-face { font-family: \"~a\";\nsrc: url(\"~a\");}" fontsym ps)))))
                           (body ((style "background: #ddd"))
                                 ,@pages))))))))))
 
+(define-syntax (cond-eq stx)
+  (syntax-case stx (else)
+    [(MAC ARG [SYM . BODY] ... [else ELSEBODY])
+     #'(cond
+         [(eq? ARG SYM) . BODY] ...
+         [else ELSEBODY])]
+    [(MAC ARG CLAUSE ...)
+     #'(MAC ARG CLAUSE ... [else (void)])]))
+
 (define (render inst-str #:using [renderer (current-renderer)])
+  (match-define ($renderer
+                 doc-start-func
+                 doc-end-func
+                 page-start-func
+                 page-end-func
+                 text-func
+                 set-font-func
+                 move-func
+                 return-func) renderer)
   (let/ec exit
     (for/fold ([stack null]
                #:result (void))
               ([tok (in-port read (open-input-string inst-str))])
-      (define next-stack (cons tok stack))
-      (cond
-        [(memq tok valid-tokens)
-         (match next-stack
-           [(list* 'doc-start rest) (($renderer-doc-start-func renderer)) rest]
-           [(list* 'doc-end _) (exit (($renderer-doc-end-func renderer)))]
-           [(list* 'page-start x y rest) (($renderer-page-start-func renderer) x y) rest]
-           [(list* 'page-end rest) (($renderer-page-end-func renderer)) rest]
-           [(list* 'text charint rest) (($renderer-text-func renderer) charint) rest]
-           [(list* 'set-font path-string rest) (($renderer-set-font-func renderer) (symbol->string path-string)) rest]
-           [(list* 'move x y rest) (($renderer-move-func renderer) x y) rest]
-           [_ next-stack])]
-        [else next-stack])))
-  (($renderer-return-func renderer)))
+      (cond-eq tok
+               ['doc-start (doc-start-func) stack]
+               ['doc-end (exit (doc-end-func)) (error 'should-never-reach)]
+               ['page-start
+                (match-define (list* x y tail) stack)
+                (page-start-func x y)
+                tail]
+               ['page-end (page-end-func) stack]
+               ['text
+                (match-define (cons charint tail) stack)
+                (text-func charint)
+                tail]
+               ['set-font
+                (match-define (cons path-string tail) stack)
+                (set-font-func (symbol->string path-string))
+                tail]
+               ['move
+                (match-define (list* x y tail) stack)
+                (move-func x y)
+                tail]
+               [else (cons tok stack)])))
+  (return-func))
 

quad2/text.rkt

@@ -0,0 +1,17 @@
+#lang debug racket/base
+(require "pipeline.rkt"
+         "quad.rkt"
+         "attr.rkt"
+         "glyphrun.rkt"
+         fontland)
+(provide (all-defined-out))
+
+(define-pass (measure-text-runs qs)
+  #:pre (list-of quad?)
+  #:post (list-of quad?)
+  (for ([q (in-list qs)]
+        #:when (eq? (quad-tag q) 'text-run))
+    (define font (get-font (quad-ref q :font-path)))
+    (define x-advance (glyph-position-x-advance (vector-ref (glyphrun-positions (layout font (car (quad-elems q)))) 0)))
+    (define font-size (quad-ref q :font-size))
+    (set-quad-size! q ($size (* (/ x-advance (font-units-per-em font) 1.0) font-size) font-size))))