improve font resolution

quad2/font.rkt

@@ -17,13 +17,15 @@
 (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 font-file-extensions '(#".otf" #".ttf" #".woff" #".woff2"))
 
-
 (define (fonts-in-directory dir)
   (for/list ([font-path (in-directory dir)]
              #:when (member (path-get-extension font-path) font-file-extensions))
@@ -82,14 +84,18 @@
   font-paths)
 
 (define (make-key font-family [bold #f] [italic #f])
+  (and font-family
        (cons (string-downcase font-family)
              (cond
                [(and bold italic) 'bi]
                [bold 'b]
                [italic 'i]
-          [else 'r])))
+               [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))
   
@@ -112,6 +118,9 @@
     ;; 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)
@@ -119,38 +128,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
+  (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))))
+                                   (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")
@@ -192,7 +209,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
@@ -200,7 +219,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))
 
 
@@ -246,7 +266,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))

quad2/main.rkt

@@ -6,20 +6,23 @@
          "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)
+         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.
@@ -55,6 +58,8 @@
    merge-adjacent-strings
    split-whitespace
    split-into-single-char-quads
+   
+   print-pass
    fill-missing-font-path
    remove-font-without-char
    insert-fallback-font

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)

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