diff --git a/quad2/attr.rkt b/quad2/attr.rkt index 112a31f6..d88f8483 100644 --- a/quad2/attr.rkt +++ b/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) diff --git a/quad2/constants.rkt b/quad2/constants.rkt index c7413171..c4812074 100644 --- a/quad2/constants.rkt +++ b/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)]) \ No newline at end of file + [: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)]) \ No newline at end of file diff --git a/quad2/font.rkt b/quad2/font.rkt index 8329c29e..7122370a 100644 --- a/quad2/font.rkt +++ b/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)))) \ No newline at end of file + (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) diff --git a/quad2/linearize.rkt b/quad2/linearize.rkt index 7dc7c09e..5379cc95 100644 --- a/quad2/linearize.rkt +++ b/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?) diff --git a/quad2/main.rkt b/quad2/main.rkt index fe8e9e17..b0fa13ce 100644 --- a/quad2/main.rkt +++ b/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] diff --git a/quad2/param.rkt b/quad2/param.rkt index 0d3ed0a9..6b0f46b8 100644 --- a/quad2/param.rkt +++ b/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] diff --git a/quad2/quad.rkt b/quad2/quad.rkt index 2c59768f..fee8b408 100644 --- a/quad2/quad.rkt +++ b/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))