diff --git a/quad2/default-fonts/default/SourceSerifPro-Regular.otf b/quad2/default-fonts/default/SourceSerifPro-Regular.otf deleted file mode 100755 index 4ff89331..00000000 Binary files a/quad2/default-fonts/default/SourceSerifPro-Regular.otf and /dev/null differ diff --git a/quad2/default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf b/quad2/default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf new file mode 100644 index 00000000..33cd4c55 Binary files /dev/null and b/quad2/default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf differ diff --git a/quad2/default-fonts/default/bold/SourceSerif4-Bold.otf b/quad2/default-fonts/default/bold/SourceSerif4-Bold.otf new file mode 100644 index 00000000..d9791f52 Binary files /dev/null and b/quad2/default-fonts/default/bold/SourceSerif4-Bold.otf differ diff --git a/quad2/default-fonts/default/italic/SourceSerif4-It.otf b/quad2/default-fonts/default/italic/SourceSerif4-It.otf new file mode 100644 index 00000000..e0fec510 Binary files /dev/null and b/quad2/default-fonts/default/italic/SourceSerif4-It.otf differ diff --git a/quad2/default-fonts/default/regular/SourceSerif4-Regular.otf b/quad2/default-fonts/default/regular/SourceSerif4-Regular.otf new file mode 100644 index 00000000..a8a651fd Binary files /dev/null and b/quad2/default-fonts/default/regular/SourceSerif4-Regular.otf differ diff --git a/quad2/font.rkt b/quad2/font.rkt index d7b4f4d6..1c9585f5 100644 --- a/quad2/font.rkt +++ b/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) - (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)) + (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]) - (cons (string-downcase font-family) - (cond - [(and bold italic) 'bi] - [bold 'b] - [italic 'i] - [else 'r]))) + (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 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 - (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 [(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) - [(? 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)])) + (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))) - (do-attr-iteration qs - #:which-attr :font-family - #:attr-proc (λ (_ __ attrs) (resolve-font-path font-paths attrs)))) + (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)))))) - (last (explode-path (quad-ref (car (resolve-font-paths qs)) :font-family)))) + (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") @@ -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)) - (and - (hash-has-key? attrs :font-features) - (not (hash-has-key? attrs :font-features-add)) - (not (hash-has-key? attrs :font-features-subtract))))) + (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 @@ -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) - (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])))))) + (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])))))) diff --git a/quad2/main.rkt b/quad2/main.rkt index 7b05a842..b5ebf77c 100644 --- a/quad2/main.rkt +++ b/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/file) + racket/match) (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 diff --git a/quad2/pipeline.rkt b/quad2/pipeline.rkt index 7843c204..1697fbdc 100644 --- a/quad2/pipeline.rkt +++ b/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) diff --git a/quad2/quad-passes.rkt b/quad2/quad-passes.rkt new file mode 100644 index 00000000..8ee00009 --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/quad2/quad.rkt b/quad2/quad.rkt index dee355f5..73f3234b 100644 --- a/quad2/quad.rkt +++ b/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))] - [fields (if (null? fields) (list #f) fields)]) - (fprintf out (format "<~a ~a>" - (or (car fields) "quad") - (string-join (map ~v (cdr fields)) " ")))))]) + ;; cdr because struct->vector puts struct descriptor in first slot + (define fields (cdr (vector->list (struct->vector val)))) + ;; cdr because tag is in first position + (fprintf out (format "<~a>" (string-join (cons (~a (or (quad-tag val) "quad")) (map ~v (filter values (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)] - #:elems [elems null]) + #:attrs [attrs #f] + #: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