diff --git a/quad2/attr.rkt b/quad2/attr.rkt index a67106de..94dba33d 100644 --- a/quad2/attr.rkt +++ b/quad2/attr.rkt @@ -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))) diff --git a/quad2/constants.rkt b/quad2/constants.rkt index 6b9fd8c1..ee2db642 100644 --- a/quad2/constants.rkt +++ b/quad2/constants.rkt @@ -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)]) \ No newline at end of file + [: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)]) \ No newline at end of file diff --git a/quad2/font.rkt b/quad2/font.rkt index 20e7be26..475d9ec0 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -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))) diff --git a/quad2/linearize.rkt b/quad2/linearize.rkt index c1c5f21e..7dc7c09e 100644 --- a/quad2/linearize.rkt +++ b/quad2/linearize.rkt @@ -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 diff --git a/quad2/main.rkt b/quad2/main.rkt index d9457143..7d6048f2 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -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 diff --git a/quad2/struct.rkt b/quad2/struct.rkt index 1379b8c7..4de50867 100644 --- a/quad2/struct.rkt +++ b/quad2/struct.rkt @@ -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