From f424e50e1f39c4a216934fbc4c0113e5c7e50ad1 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 17 Apr 2020 15:05:10 -0700 Subject: [PATCH] allow path string as font-family value --- quad/fontproof/command.rkt | 8 ++--- quad/fontproof/main.rkt | 9 ++++-- quad/quadwriter/attrs.rkt | 1 + quad/quadwriter/font.rkt | 61 ++++++++++++++++++++++++-------------- 4 files changed, 50 insertions(+), 29 deletions(-) diff --git a/quad/fontproof/command.rkt b/quad/fontproof/command.rkt index 6c0b2027..99a5c38a 100755 --- a/quad/fontproof/command.rkt +++ b/quad/fontproof/command.rkt @@ -47,14 +47,14 @@ [("-l" "--leading") line-heights-arg "line height" (set! line-heights line-heights-arg)] - [("-b" "--bold") "also generate bold proof" + [("-b" "--bold") "also generate bold proof (only works with family name)" (set! make-bold? #true)] - [("-i" "--italic") "also generate italic proof" + [("-i" "--italic") "also generate italic proof (only works with family name)" (set! make-italic? #true)] [("-q" "--qml") "output QML file" (set! output-qml? #true)] - #:args families - families)) + #:args font-family-names-or-font-paths + font-family-names-or-font-paths)) (match families [(? null?) (raise-user-error "no font to proof; exiting")] [_ (for ([family (in-list families)]) diff --git a/quad/fontproof/main.rkt b/quad/fontproof/main.rkt index 45c3b154..6b3f2652 100755 --- a/quad/fontproof/main.rkt +++ b/quad/fontproof/main.rkt @@ -42,9 +42,12 @@ (unless (and sample-text (non-empty-string? sample-text)) (raise-user-error "nothing to proof; exiting")) (define-values (initial-font-family initial-font-bold initial-font-italic) - (let ([bi-suffix-pat #px"\\s*((?i:bold))?\\s*((?i:italic))?$"]) - (match-define (list suffix bold? italic?) (regexp-match bi-suffix-pat font-name-arg)) - (values (string-trim font-name-arg suffix #:left? #false) bold? italic?))) + (match font-name-arg + [(? path-string? ps) (values (path->string (path->complete-path ps)) #f #f)] + [_ + (let ([bi-suffix-pat #px"\\s*((?i:bold))?\\s*((?i:italic))?$"]) + (match-define (list suffix bold? italic?) (regexp-match bi-suffix-pat font-name-arg)) + (values (string-trim font-name-arg suffix #:left? #false) bold? italic?))])) (log-fontproof-info (format "generating proof for ~a" font-name-arg)) (define page-size (or page-size-arg "letter")) (define font-sizes (string-split (or font-sizes-arg "12 10.5 9"))) diff --git a/quad/quadwriter/attrs.rkt b/quad/quadwriter/attrs.rkt index 9aca2ebe..6eaf4256 100644 --- a/quad/quadwriter/attrs.rkt +++ b/quad/quadwriter/attrs.rkt @@ -296,6 +296,7 @@ Naming guidelines :pdf-author :pdf-keywords :string + :font-family :footer-text :output-path)) #true)) diff --git a/quad/quadwriter/font.rkt b/quad/quadwriter/font.rkt index 081a495f..99a8ce26 100644 --- a/quad/quadwriter/font.rkt +++ b/quad/quadwriter/font.rkt @@ -41,21 +41,21 @@ #:when (directory-exists? font-family-subdir) [font-path (in-directory font-family-subdir)] #:when (member (path-get-extension font-path) font-file-extensions)) - (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 - [(member "bold-italic" path-parts) 'bi] - [(member "bold" path-parts) 'b] - [(member "italic" path-parts) '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))) + (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 + [(member "bold-italic" path-parts) 'bi] + [(member "bold" path-parts) 'b] + [(member "italic" path-parts) '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))) (define (make-key font-family [bold #f] [italic #f]) (cons (string-downcase font-family) @@ -77,9 +77,9 @@ (unless (hash-has-key? font-paths regular-key) (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)))) + (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 @@ -87,15 +87,32 @@ ;; otherwise use default [else default-font-face])) +(define (font-path-string? x) + (and (path-string? x) + (member (path-get-extension (string->path x)) '(#".otf" #".ttf" #".woff")) + #true)) + +(module+ test + (require rackunit) + (check-true (font-path-string? "foo.woff")) + (check-true (font-path-string? "foo.otf")) + (check-true (font-path-string? "foo.ttf")) + (check-false (font-path-string? "foo.woffy")) + (check-false (font-path-string? "foo"))) + + (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 (define this-font-family (hash-ref! attrs :font-family default-font-family)) - (unless (complete-path? this-font-family) - (define this-bold (hash-ref! attrs :font-bold #false)) - (define this-italic (hash-ref! attrs :font-italic #false)) - (hash-set! attrs :font-path (font-attrs->path this-font-family this-bold this-italic)))) + (hash-set! attrs :font-path + (match this-font-family + [(? font-path-string? ps) (path->complete-path ps)] + [_ + (define this-bold (hash-ref! attrs :font-bold #false)) + (define this-italic (hash-ref! attrs :font-italic #false)) + (font-attrs->path this-font-family this-bold this-italic)]))) (define (parse-em pstr) (define em-suffix "em")