#lang debug racket/base (require racket/path racket/match racket/runtime-path racket/list racket/set racket/string "attr.rkt" "quad.rkt" "constants.rkt" "pipeline.rkt" "param.rkt" "struct.rkt" "attr-passes.rkt" "glyphrun.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/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)) (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. ;; rules for font naming ;; "fonts" subdirectory on top ;; family directories inside: each named with font family name ;; this makes it possible to give font families generic names (e.g., "body-text") ;; and change the font files without disturbing anything else. (define doc-fonts-dir (simple-form-path (build-path (match/values (split-path base-path) [(base name #true) (build-path base name)] [(dir _ _) dir]) top-font-directory))) ;; run doc-fonts-dir first because earlier fonts take precedence (using hash-ref! below) (define font-paths (make-hash)) (for* ([fonts-dir (in-list (list doc-fonts-dir quad2-fonts-dir))] #:when (directory-exists? fonts-dir) [font-family-subdir (in-list (directory-list fonts-dir #:build? #t))] #: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)) 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])))) (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)) ;; if it's not already in font paths, it might be a system font ;; we use `family->path` to try to resolve the ribbi styles ;; if the font is a system font, we will end up with paths. ;; if it's not, we will end up with #false for those entries in `font-paths`, ;; and fall through to the default font when we do the `cond` below. ;; TODO: family->path doesn't work because it relies on ffi into fontconfig ;; which has broken in cs, I guess #;(unless (hash-has-key? font-paths regular-key) (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)))) (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) (and (path-string? x) (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?) ;; 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 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 (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))) (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))) #:elems null))) (last (explode-path (quad-ref (car (resolve-font-paths qs)) :font-path)))) (define (parse-em pstr) (define em-suffix "em") (and pstr (string? pstr) (string-suffix? pstr em-suffix) (string->number (string-trim pstr em-suffix)))) (define-pass (resolve-font-sizes qs) ;; convert font-size attributes into a simple font size ;; we stashed the previous size in private key 'font-size-previous #:pre (list-of quad?) #:post (list-of quad?) (define (resolve-font-size-once attrs parent-attrs) (define previous-font-size (cond [(and parent-attrs (hash-ref parent-attrs :font-size #false))] [else default-font-size])) (define base-size-adjusted (match (hash-ref attrs :font-size #false) [(? procedure? proc) ;; if our value represents an adjustment, ;; we apply the adjustment to the previous value (proc previous-font-size)] ;; otherwise we use our value directly [(? number? num) num] [other #false])) (hash-set! attrs :font-size (or base-size-adjusted previous-font-size))) (for-each-attrs qs resolve-font-size-once)) (module+ test (require rackunit) (define-attr-list debug-attrs [:font-family (make-attr-uncased-string-key 'font-family)]) (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")) (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 #:attrs (make-hasheq (list (cons :font-size "100pt"))) #: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%"))) #:elems null))))))) (check-equal? (quad-ref (quad-elems (car (resolve-font-sizes (parse-dimension-strings qs)))) :font-size) 150)) (define-pass (resolve-font-features qs) ;; put a :font-features field in every quad, ;; Along the way, resolve any :font-features-add and :font-features-subtract attrs. #: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 (resolve-font-features-once attrs parent-attrs) ;; if attrs already has an explicit :font-features key, we don't need to calculate it (unless (hash-has-key? attrs :font-features) ;; otherwise we calculate :font-features by looking at the parent features ;; and adding / removing any indicated. (define previous-features (let ([parent-attrs (or parent-attrs (hash))]) (hash-ref parent-attrs :font-features default-no-features))) (define features-to-add (hash-ref attrs :font-features-add default-no-features)) (define features-to-subtract (hash-ref attrs :font-features-subtract default-no-features)) ;; TODO: which order of operations is preferable: add then remove, or remove then add? (define these-features (set-subtract (set-union previous-features features-to-add) features-to-subtract)) (hash-set! attrs :font-features these-features)) ;; now that we've got :font-features, we can delete :font-features-add and :font-features-remove (hash-remove! attrs :font-features-add) (hash-remove! attrs :font-features-subtract)) (for-each-attrs qs resolve-font-features-once)) (module+ test (let ([qs (bootstrap-input (make-quad #:tag 'div #:attrs (make-hasheq (list (cons :font-features "ss01 liga"))) #:elems (list (make-quad #:tag 'span #:attrs (make-hasheq (list (cons :font-features-add "swsh") (cons :font-features-subtract "liga"))) #:elems (list (make-quad #:tag 'span #: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)) (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) ;; at this point we have a font-path value for each character ;; (which might be #false) ;; but we don't know if the character is in that font. ;; for quads with a font-path that doesn't contain the char, ;; we change the font-path to be #false. #:pre (list-of simple-quad-with-font-path-key?) #:post (list-of simple-quad-with-font-path-key?) (for* ([q (in-list qs)] [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))) (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]))))))