improve font resolution

quad2/font.rkt

@@ -17,17 +17,19 @@
 (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))
-            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.
@@ -49,47 +51,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)
+    (match-define (list font-path-string family-name)
-          (for/list ([x (list font-path font-family-subdir)])
+      (for/list ([x (list font-path font-family-subdir)])
-                    (path->string (find-relative-path fonts-dir x))))
+        (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))))])
+    (define path-parts (for/list ([part (in-list (explode-path (string->path (string-downcase font-path-string))))])
-                                     (path->string part)))
+                         (path->string part)))
-        (define key
+    (define key
-          (cons (string-downcase family-name)
+      (cons (string-downcase family-name)
-                (cond
+            (cond
-                  ;; special case: if there's only one style in the family directory,
+              ;; special case: if there's only one style in the family directory,
-                  ;; treat it as the regular style, regardless of name
+              ;; treat it as the regular style, regardless of name
-                  [(= (length fonts-in-this-directory) 1) 'r]
+              [(= (length fonts-in-this-directory) 1) 'r]
-                  ;; cases where fonts are in subdirectories named by style
+              ;; cases where fonts are in subdirectories named by style
-                  ;; infer style from subdir name
+              ;; infer style from subdir name
-                  [(and (member "bold" path-parts) (member "italic" path-parts)) 'bi]
+              [(and (member "bold" path-parts) (member "italic" path-parts)) 'bi]
-                  [(member "bold" path-parts) 'b]
+              [(member "bold" path-parts) 'b]
-                  [(member "italic" path-parts) 'i]
+              [(member "italic" path-parts) 'i]
-                  [else
+              [else
-                   ;; try to infer from filename alone
+               ;; try to infer from filename alone
-                   ;; TODO: what happens when there is no regular style?
+               ;; TODO: what happens when there is no regular style?
-                   (define filename (string-downcase (last path-parts)))
+               (define filename (string-downcase (last path-parts)))
-                   (define filename-contains-bold? (string-contains? filename "bold"))
+               (define filename-contains-bold? (string-contains? filename "bold"))
-                   (define filename-contains-italic? (string-contains? filename "italic"))
+               (define filename-contains-italic? (string-contains? filename "italic"))
-                   (cond
+               (cond
-                     [(and filename-contains-bold? filename-contains-italic?) 'bi]
+                 [(and filename-contains-bold? filename-contains-italic?) 'bi]
-                     [filename-contains-bold? 'b]
+                 [filename-contains-bold? 'b]
-                     [filename-contains-italic? 'i]
+                 [filename-contains-italic? 'i]
-                     [else 'r])])))
+                 [else 'r])])))
-        ;; only set value if there's not one there already.
+    ;; only set value if there's not one there already.
-        ;; this means that we only use the first eligible font we find.
+    ;; this means that we only use the first eligible font we find.
-        (hash-ref! font-paths key font-path))
+    (hash-ref! font-paths key font-path))
   font-paths)
 
 (define (make-key font-family [bold #f] [italic #f])
-  (cons (string-downcase font-family)
+  (and font-family
-        (cond
+       (cons (string-downcase font-family)
-          [(and bold italic) 'bi]
+             (cond
-          [bold 'b]
+               [(and bold italic) 'bi]
-          [italic 'i]
+               [bold 'b]
-          [else 'r])))
+               [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))
   
@@ -104,14 +110,17 @@
       (display "(fontconfig lookup unimplemented)")
       #;(for* ([bold (in-list (list #false #true))]
                [italic (in-list (list #false #true))])
-              (hash-set! font-paths
+          (hash-set! font-paths
-                         (make-key font-family bold italic)
+                     (make-key font-family bold italic)
-                         (family->path font-family #:bold bold #:italic 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)
@@ -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)
+    (hash-ref! attrs :font-path
-      [(? font-path-string? ps) (path->complete-path ps)]
+               (λ ()
-      [this-font-family
+                 (font-attrs->path font-paths
-       (define this-bold (hash-ref attrs :font-bold (λ () (error 'need-default-font-bold))))
+                                   #:family (hash-ref attrs :font-family #false)
-       (define this-italic (hash-ref attrs :font-italic (λ () (error 'need-default-font-italic))))
+                                   #:bold (hash-ref attrs :font-bold #false)
-       (font-attrs->path font-paths this-font-family this-bold this-italic)]))
+                                   #:italic (hash-ref attrs :font-italic #false))))
+    (for ([key font-family-attr-keys])
+      (hash-remove! attrs key)))
   
-  (do-attr-iteration qs
+  (for-each-attrs qs resolve-font-path))
-                     #:which-attr :font-family
-                     #:attr-proc (λ (_ __ attrs) (resolve-font-path font-paths attrs))))
 
 (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
-                                       (list (cons :font-family (string-downcase val))
+                    #:attrs (make-hasheq
-                                             (cons :font-bold bold)
+                             (list (cons :font-family (string-downcase val))
-                                             (cons :font-italic italic))))))
+                                   (cons :font-bold bold)
-  (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))
 
 
@@ -210,11 +230,11 @@
   #:pre (list-of quad?)
   #:post (λ (qs)
            (for/and ([q (in-list qs)])
-                    (define attrs (quad-attrs q))
+             (define attrs (quad-attrs q))
-                    (and
+             (and
-                     (hash-has-key? attrs :font-features)
+              (hash-has-key? attrs :font-features)
-                     (not (hash-has-key? attrs :font-features-add))
+              (not (hash-has-key? attrs :font-features-add))
-                     (not (hash-has-key? attrs :font-features-subtract)))))
+              (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
@@ -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))
@@ -265,7 +286,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
@@ -279,7 +300,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))))
@@ -290,18 +311,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)
+    (quad-update! q :font-path (λ (val)
-                                    (or
+                                 (or
-                                     val
+                                  val
-                                     (match (quad-elems q)
+                                  (match (quad-elems q)
-                                       [(cons (? string? str) _)
+                                    [(cons (? string? str) _)
-                                        (match (string-ref str 0)
+                                     (match (string-ref str 0)
-                                          ;; TODO: how to determine fallback priority for alphabetic chars?
+                                       ;; TODO: how to determine fallback priority for alphabetic chars?
-                                          ;; they are all `math?`
+                                       ;; they are all `math?`
-                                          ;; for now we will use math face for everything that's not emoji
+                                       ;; 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,
+                                       ;; later: test default-font-face to see if it contains the char,
-                                          ;; and if not, use math
+                                       ;; and if not, use math
-                                          [(? unicode:emoji? c) default-emoji-face]
+                                       [(? unicode:emoji? c) default-emoji-face]
-                                          #;[(? unicode:math? c) default-math-face]
+                                       #;[(? unicode:math? c) default-math-face]
-                                          [_ default-math-face])]
+                                       [_ default-math-face])]
-                                       [_ default-math-face]))))))
+                                    [_ default-math-face]))))))

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/match
-         racket/file)
 
 (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))]
+                ;; cdr because struct->vector puts struct descriptor in first slot
-                       [fields (if (null? fields) (list #f) fields)])
+                (define fields (cdr (vector->list (struct->vector val))))
-                  (fprintf out (format "<~a ~a>"
+                ;; cdr because tag is in first position
-                                       (or (car fields) "quad")
+                (fprintf out (format "<~a>" (string-join (cons (~a (or (quad-tag val) "quad")) (map ~v (filter values (cdr fields)))) " "))))])
-                                       (string-join (map ~v (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)]
+                            #:attrs [attrs #f]
-                            #:elems [elems null])
+                            #: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