mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

tag attr-keys as mandatory and provide default values

Browse Source
main
Matthew Butterick 3 years ago
parent 6175eeb909
commit 93ed327a32
6 changed files with 134 additions and 107 deletions
Show Stats Download Patch File Download Diff File

75
quad2/attr.rkt
Unescape Escape View File

@ -12,34 +12,39 @@
"param.rkt")
(provide (all-defined-out))
(define (for-each-attrs xs proc)
(define attrs-seen (mutable-seteq))
(let loop ([xs xs][parent-attrs #false])
(for ([x (in-list xs)]
#:when (quad? x))
(let* ([attrs (quad-attrs x)])
(unless (set-member? attrs-seen attrs)
(proc attrs parent-attrs)
(set-add! attrs-seen attrs))
(loop (quad-elems x) attrs)))))
(define (do-attr-iteration qs
#:which-attr [which-attr #false]
#:attr-proc attr-proc)
#:which-attr [which-attr 'all-attributes-signal]
#:attr-proc attr-proc
#:wants-parent-attrs [wants-parent-attrs? #false])
(define attr-predicate
(match which-attr
[#false (λ (ak av) #true)]
['all-attributes-signal (λ (ak av) #true)]
[(? attr-key? attr-key) (λ (ak av) (eq? ak attr-key))]
[(? procedure? pred)
(if (eq? 1 (procedure-arity pred))
(λ (ak _) (pred ak)) ; 1 arity implies key-only test
pred)]
[other (raise-argument-error 'do-attr-iteration "key predicate" other)]))
(define attrs-seen (mutable-seteq))
(let loop ([xs qs])
(for ([x (in-list xs)]
#:when (quad? x))
(let* ([q x]
[attrs (quad-attrs q)])
(unless (set-member? attrs-seen attrs)
(for ([(ak av) (in-hash attrs)]
#:when (attr-predicate ak av))
(match (attr-proc ak av attrs)
;; void value: do nothing
[(? void?) (void)]
;; otherwise treat return value as new attr value
[new-av (hash-set! attrs ak new-av)]))
(set-add! attrs-seen attrs))
(loop (quad-elems q))))))
(for-each-attrs qs
(λ (attrs parent-attrs)
(for ([(ak av) (in-hash attrs)]
#:when (attr-predicate ak av))
(match (if wants-parent-attrs? (attr-proc ak av attrs parent-attrs) (attr-proc ak av attrs))
;; void value: do nothing
[(? void?) (void)]
;; otherwise treat return value as new attr value
[new-av (hash-set! attrs ak new-av)])))))
(define-pass (upgrade-attr-keys qs)
;; convert attr keys from symbols to attr struct types
@ -63,6 +68,14 @@
[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)
#: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-pass (downcase-attr-values qs)
;; make attribute values lowercase, unless they're case-sensitive
;; so we can check them more easily later.
@ -84,8 +97,9 @@
(do-attr-iteration qs
#:which-attr attr-boolean-key?
#:attr-proc (λ (ak av attrs)
(match (string-downcase av)
["false" #false]
(match av
[(? boolean?) av]
[(? string? str) #:when (equal? (string-downcase str) "false") #false]
[_ #true]))))
(define-pass (convert-numeric-attr-values qs)
@ -97,6 +111,7 @@
(or (string->number av)
(raise-argument-error 'convert-numeric-attr-values "numeric string" av)))))
(define-pass (complete-attr-paths qs)
#:pre (list-of quad?)
#:post (list-of quad?)
@ -116,15 +131,18 @@
#:which-attr attr-dimension-string-key?
#:attr-proc (λ (ak av attrs) (parse-dimension av))))
(module+ test
(require rackunit)
(define-attr-list debug-attrs
[:foo (attr-cased-string-key 'foo)]
[:ps (attr-path-key 'ps)]
[:dim (attr-dimension-string-key 'dim)]
[:boolt (attr-boolean-key 'bool)]
[:boolf (attr-boolean-key 'bool)]
[:num (attr-numeric-key 'num)])
[:foo (make-attr-cased-string-key 'foo)]
[:ps (make-attr-path-key 'ps)]
[:dim (make-attr-dimension-string-key 'dim)]
[:boolt (make-attr-boolean-key 'bool)]
[:boolf (make-attr-boolean-key 'bool)]
[:num (make-attr-numeric-key 'num)]
[:num-def-42 (make-attr-numeric-key 'num-def-42 #true 42)])
(parameterize ([current-attrs debug-attrs])
(define (make-q) (make-quad #:attrs (make-hasheq (list (cons :foo "BAR")
(cons 'ding "dong")
@ -140,9 +158,10 @@
(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 (downcase-attr-values qs)) :foo) "bar")
(check-true (complete-path? (quad-ref (car (complete-attr-paths qs)) :ps)))
(check-true (procedure? (quad-ref (car (parse-dimension-strings qs)) :dim)))
(check-equal? (quad-ref (car (parse-dimension-strings qs)) :dim) 144)
(let ([q (car (convert-boolean-attr-values qs))])
(check-true (quad-ref q :boolt))
(check-false (quad-ref q :boolf)))

17
quad2/constants.rkt
Unescape Escape View File

@ -2,6 +2,9 @@
(require "struct.rkt")
(provide (all-defined-out))
(define default-font-family "text")
(define default-font-size 12)
(define-syntax-rule (define-attr-list LIST-NAME
[ATTR-NAME ATTR-EXPR] ...)
(begin
@ -9,10 +12,10 @@
(define LIST-NAME (list ATTR-NAME ...))))
(define-attr-list all-attrs
[:unknown-key (attr-unknown-key (gensym))]
[:font-family (attr-uncased-string-key 'font-family)]
[:font-path (attr-path-key 'font-path)]
[:font-bold (attr-boolean-key 'font-bold)]
[:font-italic (attr-boolean-key 'font-italic)]
[:font-size (attr-dimension-string-key 'font-size)]
[:font-size-previous (attr-dimension-string-key 'font-size-previous)])
[: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-size-previous (make-attr-dimension-string-key 'font-size-previous)])

105
quad2/font.rkt
Unescape Escape View File

@ -18,13 +18,12 @@
(define-runtime-path default-font-face "default-fonts/default/SourceSerifPro-Regular.otf")
(define top-font-directory "fonts")
(define font-file-extensions '(#".otf" #".ttf" #".woff" #".woff2"))
(define default-font-family "text")
(define default-font-size 12)
(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.
@ -46,36 +45,36 @@
#: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
[(member "bold-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
[(member "bold-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])
@ -101,9 +100,9 @@
(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
@ -116,16 +115,16 @@
(member (path-get-extension (string->path x)) font-file-extensions)
#true))
(define (resolve-font-path font-paths val attrs)
(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 default-font-family))
(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 #false))
(define this-italic (hash-ref! attrs :font-italic #false))
(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)
@ -137,7 +136,7 @@
(define font-paths (setup-font-path-table))
(do-attr-iteration qs
#:which-attr :font-family
#:attr-proc (λ (ak av attrs) (resolve-font-path font-paths av attrs))))
#:attr-proc (λ (_ __ attrs) (resolve-font-path font-paths attrs))))
(define (resolved-font-for-family val #:bold [bold #f] #:italic [italic #f])
(define qs (list (make-quad #:attrs (make-hasheq
@ -146,16 +145,6 @@
(cons :font-italic italic))))))
(last (explode-path (quad-ref (car (resolve-font-paths qs)) :font-family))))
(module+ test
(require rackunit)
(define-attr-list debug-attrs
[:font-family (attr-uncased-string-key 'font-family)])
(parameterize ([current-attrs debug-attrs])
(check-equal? (resolved-font-for-family "Heading") (string->path "fira-sans-light.otf"))
(check-equal? (resolved-font-for-family "CODE") (string->path "fira-mono.otf"))
(check-equal? (resolved-font-for-family "blockquote" #:bold #t) (string->path "fira-sans-bold.otf"))
(check-equal? (resolved-font-for-family "nonexistent-fam") (string->path "SourceSerifPro-Regular.otf"))))
(define (parse-em pstr)
(define em-suffix "em")
(and
@ -188,9 +177,17 @@
(define font-paths (setup-font-path-table))
(do-attr-iteration qs
#:attr-proc (λ (ak av attrs) (resolve-font-size-once attrs))))
#:attr-proc (λ (_ __ attrs) (resolve-font-size-once attrs))))
(module+ test
(require rackunit)
(define-attr-list debug-attrs
[:font-family (make-attr-uncased-string-key 'font-family)])
(parameterize ([current-attrs debug-attrs])
(check-equal? (resolved-font-for-family "Heading") (string->path "fira-sans-light.otf"))
(check-equal? (resolved-font-for-family "CODE") (string->path "fira-mono.otf"))
(check-equal? (resolved-font-for-family "blockquote" #:bold #t) (string->path "fira-sans-bold.otf"))
(check-equal? (resolved-font-for-family "nonexistent-fam") (string->path "SourceSerifPro-Regular.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-previous "100pt") (cons :font-size "1.5em"))))))))
(resolve-font-sizes (parse-dimension-strings qs)))
#;(resolve-font-sizes (parse-dimension-strings qs)))

15
quad2/linearize.rkt
Unescape Escape View File

@ -7,7 +7,20 @@
"quad.rkt")
(provide (all-defined-out))
(define (simple-quad? x) (and (quad? x) (<= (length (quad-elems x)) 1)))
(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?)
#:post (list-of simple-quad?)
(append*
(for/list ([q (in-list qs)])
(match q
[(quad _ _ (list (? string? str)) _)
(for/list ([c (in-string str)])
(struct-copy quad q [elems (list (string c))]))]
[_ (list q)]))))
(define-pass (linearize qs)
;; convert a single quad into a list of quads, with the attributes propagated downward

16
quad2/main.rkt
Unescape Escape View File

@ -12,18 +12,6 @@
racket/list
racket/match)
(define-pass (split-into-single-char-quads qs)
;; break list of quads into single characters (keystrokes)
#:pre (list-of simple-quad?)
#:post (list-of simple-quad?)
(append*
(for/list ([q (in-list qs)])
(match q
[(quad _ _ (list (? string? str)) _)
(for/list ([c (in-string str)])
(struct-copy quad q [elems (list (string c))]))]
[_ (list q)]))))
(define quad-compile
(make-pipeline (list
;; each pass in the pipeline is at least
@ -33,10 +21,12 @@
;; all attrs start out as symbol-string pairs.
;; we convert keys & values to corresponding higher-level types.
upgrade-attr-keys
fill-default-attr-values
downcase-attr-values
convert-boolean-attr-values
convert-numeric-attr-values
parse-dimension-strings
resolve-font-sizes
;; linearization =============
;; we postpone this step until we're certain any
@ -47,8 +37,6 @@
linearize
;; resolutions & parsings =============
;; TODO: finish resolve-font-sizes
#;resolve-font-sizes
resolve-font-paths
complete-attr-paths
;; TODO: parse feature strings

13
quad2/struct.rkt
Unescape Escape View File

@ -8,14 +8,21 @@
(struct $doc $drawing-inst (inst) #:transparent)
(struct $page $drawing-inst (inst) #:transparent)
(struct attr-key (name) #:transparent)
(struct attr-key (name mandatory? default) #:transparent)
(define (make-attr-key name [mandatory? #false] [default #false])
(attr-key name mandatory? default))
(define-syntax (define-attr-key-types stx)
(syntax-case stx ()
[(_ ID ...)
(with-syntax ([(ATTR-ID-KEY ...) (map (λ (id-stx) (format-id stx "attr-~a-key" id-stx)) (syntax->list #'(ID ...)))])
(with-syntax ([(ATTR-ID-KEY ...) (map (λ (id-stx) (format-id stx "attr-~a-key" id-stx)) (syntax->list #'(ID ...)))]
[(MAKE-ATTR-ID-KEY ...) (map (λ (id-stx) (format-id stx "make-attr-~a-key" id-stx)) (syntax->list #'(ID ...)))])
#'(begin
(struct ATTR-ID-KEY attr-key () #:transparent) ...))]))
(begin
(struct ATTR-ID-KEY attr-key () #:transparent)
(define (MAKE-ATTR-ID-KEY name [mandatory #false] [default #false])
(ATTR-ID-KEY name mandatory default))) ...))]))
;; for type X, creates struct called attr-X-key
(define-attr-key-types

Write Preview
Loading…
Cancel
Save