add font & attr passes

quad2/attr.rkt

@@ -42,7 +42,6 @@
            (λ (ak _) (pred ak)) ; 1 arity implies key-only test
            pred)]
       [other (raise-argument-error 'do-attr-iteration "key predicate" other)]))
-  (define no-value-signal (gensym))
   (for-each-attrs qs
                   (λ (attrs parent-attrs)
                     ;; we don't iterate with `in-hash` (or `in-hash-keys`) because
@@ -64,7 +63,7 @@
   ;; 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-attrs))])
+  (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)
@@ -80,13 +79,15 @@
       [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)]))
   (do-attr-iteration qs #:attr-proc do-upgrade))
 
-(define-pass (fill-default-attr-values qs)
+(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-keys (filter attr-key-mandatory? (current-attrs)))
-  (for-each-attrs qs (λ (attrs parent-attrs)
-                       (for ([ak (in-list mandatory-keys)])
-                            (hash-ref! attrs ak (attr-key-default ak))))))
+  (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
@@ -179,7 +180,7 @@
     [: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-attrs debug-attrs])
+  (parameterize ([current-attr-keys debug-attrs])
     (define (make-q) (make-quad #:attrs (list :foo "BAR"
                                               'ding "dong"
                                               :ps (string->path "file.txt")
@@ -194,7 +195,7 @@
     (check-not-exn (λ ()
                      (parameterize ([current-strict-attrs? #false])
                        (upgrade-attr-keys (list (make-q))))))
-    (check-equal? (quad-ref (car (fill-default-attr-values (list (make-q)))) :num-def-42) 42)
+    (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)

quad2/constants.rkt

@@ -8,6 +8,9 @@
 (define default-font-size 12)
 (define default-no-features (seteq))
 
+(struct no-value ())
+(define no-value-signal (no-value))
+
 (define-syntax-rule (define-attr-list LIST-NAME
                       [ATTR-NAME ATTR-EXPR] ...)
   (begin
@@ -20,13 +23,13 @@
            (λ (sym) (raise-user-error 'define-attr-list "duplicate attribute name: ~a" sym))]
           [else names])))))
 
-(define-attr-list all-attrs
+(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 default-no-features)]
-  [:font-features-add (make-attr-set-key 'font-features-add default-no-features)]
-  [:font-features-subtract (make-attr-set-key 'font-features-subtract default-no-features)])
+  [: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)])

quad2/font.rkt

@@ -12,11 +12,14 @@
          "param.rkt"
          "struct.rkt"
          "dimension.rkt"
-         "attr.rkt")
+         "attr.rkt"
+         (prefix-in unicode: (combine-in "unicode/emoji.rkt" "unicode/math.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-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"))
 
@@ -116,17 +119,7 @@
        (member (path-get-extension (string->path x)) font-file-extensions)
        #true))
 
-(define (resolve-font-path font-paths 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
-  (define this-font-family (hash-ref attrs :font-family (λ () (error 'need-default-font-family))))
-  (match (string-downcase this-font-family)
-    [(? font-path-string? ps) (path->complete-path ps)]
-    [_
-     (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)]))
+
 
 (define-pass (resolve-font-paths qs)
   ;; convert references to a font family and style to an font path on disk
@@ -135,6 +128,19 @@
   #:pre (list-of quad?)
   #:post (list-of quad?)
   (define font-paths (setup-font-path-table))
+
+  (define (resolve-font-path font-paths 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 (string-downcase (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)]))
+  
   (do-attr-iteration qs
                      #:which-attr :font-family
                      #:attr-proc (λ (_ __ attrs) (resolve-font-path font-paths attrs))))
@@ -182,7 +188,7 @@
   (require rackunit)
   (define-attr-list debug-attrs
     [:font-family (make-attr-uncased-string-key 'font-family)])
-  (parameterize ([current-attrs debug-attrs])
+  (parameterize ([current-attr-keys debug-attrs])
     (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"))
@@ -244,4 +250,56 @@
     (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))
-    (check-equal? (quad-ref (car (quad-elems (car (quad-elems q)))) :font-features) (seteq 'hist))))
+    (check-equal? (quad-ref (car (quad-elems (car (quad-elems q)))) :font-features) (seteq 'hist))))
+
+
+(define (simple-quad-with-font-path-key? q)
+  (and (simple-quad? q)
+       (match (quad-ref q :font-path no-value-signal)
+         [(or #false (? complete-path?)) #true]
+         [_ #false])))
+
+(define-pass (fill-missing-font-path qs)
+  ;; ensure every quad has a valid :font-path value
+  ;; if it has no value, use #false
+  #:pre (list-of quad?)
+  #:post (list-of simple-quad-with-font-path-key?)
+  (for ([q (in-list qs)])
+       (quad-ref! q :font-path #false)))
+
+(define-pass (remove-font-without-char qs)
+  ;; TODO: missing glyphs
+  ;; at this point we have a font-path for each character
+  ;; but we don't know if the character is in that font.
+  ;; for chars whose font is missing, we mark the font-path as #false.
+  #:pre (list-of simple-quad-with-font-path-key?)
+  #:post (list-of simple-quad-with-font-path-key?)
+  (error 'remove-font-without-char-unimplemented)
+  qs
+  )
+
+(define (simple-quad-with-complete-font-path? q)
+  (and (simple-quad? q) (complete-path? (quad-ref q :font-path))))
+
+(define-pass (insert-fallback-font qs)
+  ;; for chars whose font is missing (that is, :font-path is #false)
+  ;; set a new fallback font based on whether char is emoji, math, or other
+  #: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])))))
+  qs)

quad2/linearize.rkt

@@ -7,9 +7,6 @@
          "quad.rkt")
 (provide (all-defined-out))
 
-(define (simple-quad? x)
-  (and (quad? x) (<= (length (quad-elems x)) 1)))
-
 (define-pass (split-into-single-char-quads qs)
   ;; break list of quads into single characters (keystrokes)
   #:pre (list-of simple-quad?)

quad2/main.rkt

@@ -21,18 +21,15 @@
                   ;; all attrs start out as symbol-string pairs.
                   ;; we convert keys & values to corresponding higher-level types.
                   upgrade-attr-keys
-                  ;; I think `fill-default-attr-values` here is wrong.
-                  ;; It will prevent parent values from cascading during linearization.
-                  ;; But it would be OK at the top level, to ensure
-                  ;; that there are values that cascade.
-                  ;; But that can also be done by wrapping in a quad with the default values.
-                  #;fill-default-attr-values
                   downcase-string-attr-values
                   convert-boolean-attr-values
                   convert-numeric-attr-values
                   convert-set-attr-values
                   convert-path-attr-values
 
+                  ;; wrap default values around top level
+                  set-top-level-attr-values
+
                   ;; pre-linearization resolutions & parsings =============
                   ;; these need the tree shape
                   parse-dimension-strings
@@ -55,7 +52,9 @@
                   merge-adjacent-strings
                   split-whitespace
                   split-into-single-char-quads
-                  ;; TODO: missing glyphs
+                  fill-missing-font-path
+                  #;remove-font-without-char
+                  insert-fallback-font
                   layout
                   make-drawing-insts
                   stackify)))
@@ -64,7 +63,7 @@
   (require "render.rkt")
   (define (test-compile x)
     (parameterize ([current-wrap-width 13]
-                   [current-attrs all-attrs]
+                   [current-attr-keys all-attr-keys]
                    [current-strict-attrs? #t]
                    [current-show-timing? #f]
                    [current-use-preconditions? #t]

quad2/param.rkt

@@ -14,7 +14,7 @@
                         val))) ...))
 
 (define-guarded-parameters
-  [current-attrs (λ (xs) (and (list? xs) (andmap attr-key? xs))) all-attrs]
+  [current-attr-keys (λ (xs) (and (list? xs) (andmap attr-key? xs))) all-attr-keys]
   [current-show-timing? boolean? #false]
   [current-strict-attrs? boolean? #false]
   [current-use-preconditions? boolean? #true]

quad2/quad.rkt

@@ -4,6 +4,7 @@
          racket/hash
          txexpr
          (for-syntax racket/base racket/syntax)
+         "constants.rkt"
          "struct.rkt")
 (provide (all-defined-out))
 
@@ -51,17 +52,27 @@
                    [else attrs]))])
     (quad-constructor tag attrs elems #false)))
 
-(define (quad-ref q-or-qs key [default-val #false])
+(define (quad-ref q-or-qs key [default-val #false] #:set-default-if-missing [set-default-if-missing? #false])
   (unless (attr-key? key)
     (raise-argument-error 'quad-ref "attr-key?" key))
-  (hash-ref (quad-attrs (match q-or-qs
-                          [(? quad? q) q]
-                          [(cons q _) q]
-                          [_ (raise-argument-error 'quad-ref "quad or list of quads" q-or-qs)])) key default-val))
+  (define hash-reffer (if set-default-if-missing? hash-ref! hash-ref))
+  (hash-reffer (quad-attrs (match q-or-qs
+                             [(? quad? q) q]
+                             [(cons q _) q]
+                             [_ (raise-argument-error 'quad-ref "quad or list of quads" q-or-qs)])) key default-val))
 
 (define (quad-set! q key val)
   (hash-set! (quad-attrs q) key val))
 
+(define (quad-update! q key updater)
+  (hash-update! (quad-attrs q) key updater))
+
+(define (quad-ref! q-or-qs key default-val)
+  (quad-ref q-or-qs key default-val #:set-default-if-missing #true))
+
+(define (quad-has-key? q-or-qs key)
+  (not (eq? (quad-ref q-or-qs key no-value-signal) no-value-signal)))
+
 (define-syntax (define-quad-field stx)
   (syntax-case stx ()
     [(_ FIELD)
@@ -73,6 +84,9 @@
 
 #;(define-quad-field posn)
 
+(define (simple-quad? x)
+  (and (quad? x) (<= (length (quad-elems x)) 1)))
+
 (define (has-no-position? q) (not (has-position? q)))
 (define (has-position? q) (quad-posn q))