From e2c2f9429c0f187e3f4d093629c75fd482c53bf4 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 16 May 2022 07:55:16 -0700 Subject: [PATCH] define attrs in attr.rkt put other ops in attr-passes --- quad2/attr-passes.rkt | 205 +++++++++++++++++++++++++++++++++++++ quad2/attr.rkt | 232 ++++++------------------------------------ quad2/constants.rkt | 32 +----- quad2/draw.rkt | 8 +- quad2/font.rkt | 7 +- quad2/main.rkt | 1 + quad2/page.rkt | 1 + quad2/param.rkt | 1 + 8 files changed, 245 insertions(+), 242 deletions(-) create mode 100644 quad2/attr-passes.rkt diff --git a/quad2/attr-passes.rkt b/quad2/attr-passes.rkt new file mode 100644 index 00000000..fed9dcc6 --- /dev/null +++ b/quad2/attr-passes.rkt @@ -0,0 +1,205 @@ +#lang debug racket/base +(require racket/match + racket/string + racket/set + "attr.rkt" + "dimension.rkt" + "pipeline.rkt" + "struct.rkt" + "constants.rkt" + "quad.rkt" + "param.rkt") +(provide (all-defined-out)) + +(module+ test + (require rackunit)) + +(define (for-each-attrs xs proc) + ;; apply `proc` to each set of attrs in `xs`. + ;; recursively descend from top to bottom. + ;; but also track which attrs are visited and skip any already visited. + (define attrs-seen (mutable-seteq)) + (define wants-parent-attrs? (= (procedure-arity proc) 2)) + (let loop ([xs xs][parent-attrs #false]) + (for ([x (in-list xs)] + #:when (quad? x)) + (define attrs (quad-attrs x)) + (unless (set-member? attrs-seen attrs) + (if wants-parent-attrs? (proc attrs parent-attrs) (proc attrs)) + (set-add! attrs-seen attrs)) + (loop (quad-elems x) attrs)))) + +(define (do-attr-iteration qs + #:which-attr [which-attr 'all-attributes-signal] + #:attr-proc attr-proc + #:wants-parent-attrs [wants-parent-attrs? #false]) + (define attr-predicate + (match which-attr + ['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)])) + (for-each-attrs qs + (λ (attrs parent-attrs) + ;; we don't iterate with `in-hash` (or `in-hash-keys`) because + ;; `attrs` might get mutated during the loop, + ;; which invalidates the reference `in-hash` is using + (for* ([ak (in-list (hash-keys attrs))] + [av (in-value (hash-ref attrs ak no-value-signal))] + #:when (and (not (eq? av no-value-signal)) (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 + ;; also lets us validate keys strictly, if we want + #:pre (list-of quad?) + #:post (list-of quad?) + (define attr-lookup-table (for/hasheq ([a (in-list (current-attr-keys))]) + (values (attr-key-name a) a))) + (define strict-attrs? (current-strict-attrs?)) + (define (do-upgrade ak av attrs) + (cond + [(attr-key? ak) av] + [(symbol? ak) + (match (hash-ref attr-lookup-table ak :unknown-key) + [(== :unknown-key eq?) #:when strict-attrs? + (raise-argument-error 'upgrade-attr-keys "known attr" ak)] + [attr-key + (hash-remove! attrs ak) + (hash-set! attrs attr-key av)])] + [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)])) + (do-attr-iteration qs #:attr-proc do-upgrade)) + +(define-pass (set-top-level-attr-values qs) + ;; put the default values for mandatory keys at the top level + ;; so that when we linearize, they will percolate downward + #:pre (list-of quad?) + #:post (list-of quad?) + (define mandatory-attrs (for/hasheq ([ak (in-list (current-attr-keys))] + #:when (attr-key-mandatory? ak)) + (values ak (attr-key-default ak)))) + (list (make-quad #:attrs mandatory-attrs #:elems qs))) + +(define-pass (downcase-string-attr-values qs) + ;; make attribute values lowercase, unless they're case-sensitive + ;; so we can check them more easily later. + ;; in principle we could do this earlier and recursively process a single quad + ;; rather than linearized quads + ;; it would be faster because there are fewer copies of the attr hashes, + ;; so we do fewer tests + ;; but let's stay with the pipeline policy of operating on flat lists of quads + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-cased-string-key? + #:attr-proc (λ (ak av attrs) (string-downcase av)))) + + +(define-pass (convert-boolean-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-boolean-key? + #:attr-proc (λ (ak av attrs) + (match av + [(? boolean?) av] + [(? string? str) #:when (equal? (string-downcase str) "false") #false] + [_ #true])))) + +(define-pass (convert-numeric-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-numeric-key? + #:attr-proc (λ (ak av attrs) + (or (string->number av) + (raise-argument-error 'convert-numeric-attr-values "numeric string" av))))) + +(define-pass (convert-path-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-path-key? + #:attr-proc (λ (ak av attrs) + (or (string->path av) + (raise-argument-error 'convert-path-attr-values "path string" av))))) + +(define-pass (convert-set-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-set-key? + #:attr-proc (λ (ak av attrs) + (apply seteq (map string->symbol (string-split av)))))) + +(module+ test + (let ([q (convert-set-attr-values (upgrade-attr-keys (bootstrap-input '(div ((font-features "calt")(font-features-add "")(font-features-subtract "swsh liga"))))))]) + (check-equal? (quad-ref q :font-features) (seteq 'calt)) + (check-equal? (quad-ref q :font-features-add) (seteq)) + (check-equal? (quad-ref q :font-features-subtract) (seteq 'swsh 'liga)))) + + +(define-pass (complete-attr-paths qs) + #:pre (list-of quad?) + #:post (list-of quad?) + ;; convert every path value to a complete path + ;; so we don't get tripped up later by relative paths + ;; relies on `current-directory` being parameterized to source file's dir + (do-attr-iteration qs + #:which-attr attr-path-key? + #:attr-proc (λ (ak av attrs) + (unless (path? av) + (raise-argument-error 'complete-attr-paths "path" av)) + (path->complete-path av)))) + + +(define-pass (parse-dimension-strings qs) + #:pre (list-of quad?) + #:post (list-of quad?) + ;; certain attributes can be "dimension strings", which are strings like "3in" or "4.2cm" + ;; we parse them into the equivalent measurement in points. + (do-attr-iteration qs + #:which-attr attr-dimension-string-key? + #:attr-proc (λ (ak av attrs) (parse-dimension av)))) + +(module+ test + (define-attr-list debug-attrs + [: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 'boolt)] + [:boolf (make-attr-boolean-key 'boolf)] + [:num (make-attr-numeric-key 'num)] + [:num-def-42 (make-attr-numeric-key 'num-def-42 #true 42)]) + (parameterize ([current-attr-keys debug-attrs]) + (define (make-q) (make-quad #:attrs (list :foo "BAR" + 'ding "dong" + :ps (string->path "file.txt") + :dim "2in" + :boolt "true" + :boolf "false" + :num "42.5"))) + (define qs (list (make-q))) + (check-exn exn? (λ () + (parameterize ([current-strict-attrs? #true]) + (upgrade-attr-keys (list (make-q)))))) + (check-not-exn (λ () + (parameterize ([current-strict-attrs? #false]) + (upgrade-attr-keys (list (make-q)))))) + (check-equal? (quad-ref (car (set-top-level-attr-values (list (make-q)))) :num-def-42) 42) + (check-equal? (quad-ref (car (downcase-string-attr-values qs)) :foo) "bar") + (check-true (complete-path? (quad-ref (car (complete-attr-paths qs)) :ps))) + (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))) + (check-equal? (quad-ref (car (convert-numeric-attr-values qs)) :num) 42.5))) \ No newline at end of file diff --git a/quad2/attr.rkt b/quad2/attr.rkt index e80ef09b..342240b4 100644 --- a/quad2/attr.rkt +++ b/quad2/attr.rkt @@ -1,206 +1,34 @@ #lang debug racket/base -(require racket/match - racket/hash - racket/list - racket/string - racket/set - "dimension.rkt" - "pipeline.rkt" +(require racket/list "struct.rkt" - "constants.rkt" - "quad.rkt" - "param.rkt") + "constants.rkt") (provide (all-defined-out)) -(module+ test - (require rackunit)) - -(define (for-each-attrs xs proc) - ;; apply `proc` to each set of attrs in `xs`. - ;; recursively descend from top to bottom. - ;; but also track which attrs are visited and skip any already visited. - (define attrs-seen (mutable-seteq)) - (define wants-parent-attrs? (= (procedure-arity proc) 2)) - (let loop ([xs xs][parent-attrs #false]) - (for ([x (in-list xs)] - #:when (quad? x)) - (define attrs (quad-attrs x)) - (unless (set-member? attrs-seen attrs) - (if wants-parent-attrs? (proc attrs parent-attrs) (proc attrs)) - (set-add! attrs-seen attrs)) - (loop (quad-elems x) attrs)))) - -(define (do-attr-iteration qs - #:which-attr [which-attr 'all-attributes-signal] - #:attr-proc attr-proc - #:wants-parent-attrs [wants-parent-attrs? #false]) - (define attr-predicate - (match which-attr - ['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)])) - (for-each-attrs qs - (λ (attrs parent-attrs) - ;; we don't iterate with `in-hash` (or `in-hash-keys`) because - ;; `attrs` might get mutated during the loop, - ;; which invalidates the reference `in-hash` is using - (for* ([ak (in-list (hash-keys attrs))] - [av (in-value (hash-ref attrs ak no-value-signal))] - #:when (and (not (eq? av no-value-signal)) (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 - ;; also lets us validate keys strictly, if we want - #:pre (list-of quad?) - #:post (list-of quad?) - (define attr-lookup-table (for/hasheq ([a (in-list (current-attr-keys))]) - (values (attr-key-name a) a))) - (define strict-attrs? (current-strict-attrs?)) - (define (do-upgrade ak av attrs) - (cond - [(attr-key? ak) av] - [(symbol? ak) - (match (hash-ref attr-lookup-table ak :unknown-key) - [(== :unknown-key eq?) #:when strict-attrs? - (raise-argument-error 'upgrade-attr-keys "known attr" ak)] - [attr-key - (hash-remove! attrs ak) - (hash-set! attrs attr-key av)])] - [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)])) - (do-attr-iteration qs #:attr-proc do-upgrade)) - -(define-pass (set-top-level-attr-values qs) - ;; put the default values for mandatory keys at the top level - ;; so that when we linearize, they will percolate downward - #:pre (list-of quad?) - #:post (list-of quad?) - (define mandatory-attrs (for/hasheq ([ak (in-list (current-attr-keys))] - #:when (attr-key-mandatory? ak)) - (values ak (attr-key-default ak)))) - (list (make-quad #:attrs mandatory-attrs #:elems qs))) - -(define-pass (downcase-string-attr-values qs) - ;; make attribute values lowercase, unless they're case-sensitive - ;; so we can check them more easily later. - ;; in principle we could do this earlier and recursively process a single quad - ;; rather than linearized quads - ;; it would be faster because there are fewer copies of the attr hashes, - ;; so we do fewer tests - ;; but let's stay with the pipeline policy of operating on flat lists of quads - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-cased-string-key? - #:attr-proc (λ (ak av attrs) (string-downcase av)))) - - -(define-pass (convert-boolean-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-boolean-key? - #:attr-proc (λ (ak av attrs) - (match av - [(? boolean?) av] - [(? string? str) #:when (equal? (string-downcase str) "false") #false] - [_ #true])))) - -(define-pass (convert-numeric-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-numeric-key? - #:attr-proc (λ (ak av attrs) - (or (string->number av) - (raise-argument-error 'convert-numeric-attr-values "numeric string" av))))) - -(define-pass (convert-path-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-path-key? - #:attr-proc (λ (ak av attrs) - (or (string->path av) - (raise-argument-error 'convert-path-attr-values "path string" av))))) - -(define-pass (convert-set-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-set-key? - #:attr-proc (λ (ak av attrs) - (apply seteq (map string->symbol (string-split av)))))) - -(module+ test - (let ([q (convert-set-attr-values (upgrade-attr-keys (bootstrap-input '(div ((font-features "calt")(font-features-add "")(font-features-subtract "swsh liga"))))))]) - (check-equal? (quad-ref q :font-features) (seteq 'calt)) - (check-equal? (quad-ref q :font-features-add) (seteq)) - (check-equal? (quad-ref q :font-features-subtract) (seteq 'swsh 'liga)))) - - -(define-pass (complete-attr-paths qs) - #:pre (list-of quad?) - #:post (list-of quad?) - ;; convert every path value to a complete path - ;; so we don't get tripped up later by relative paths - ;; relies on `current-directory` being parameterized to source file's dir - (do-attr-iteration qs - #:which-attr attr-path-key? - #:attr-proc (λ (ak av attrs) - (unless (path? av) - (raise-argument-error 'complete-attr-paths "path" av)) - (path->complete-path av)))) - - -(define-pass (parse-dimension-strings qs) - #:pre (list-of quad?) - #:post (list-of quad?) - ;; certain attributes can be "dimension strings", which are strings like "3in" or "4.2cm" - ;; we parse them into the equivalent measurement in points. - (do-attr-iteration qs - #:which-attr attr-dimension-string-key? - #:attr-proc (λ (ak av attrs) (parse-dimension av)))) - -(module+ test - (define-attr-list debug-attrs - [: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 'boolt)] - [:boolf (make-attr-boolean-key 'boolf)] - [:num (make-attr-numeric-key 'num)] - [:num-def-42 (make-attr-numeric-key 'num-def-42 #true 42)]) - (parameterize ([current-attr-keys debug-attrs]) - (define (make-q) (make-quad #:attrs (list :foo "BAR" - 'ding "dong" - :ps (string->path "file.txt") - :dim "2in" - :boolt "true" - :boolf "false" - :num "42.5"))) - (define qs (list (make-q))) - (check-exn exn? (λ () - (parameterize ([current-strict-attrs? #true]) - (upgrade-attr-keys (list (make-q)))))) - (check-not-exn (λ () - (parameterize ([current-strict-attrs? #false]) - (upgrade-attr-keys (list (make-q)))))) - (check-equal? (quad-ref (car (set-top-level-attr-values (list (make-q)))) :num-def-42) 42) - (check-equal? (quad-ref (car (downcase-string-attr-values qs)) :foo) "bar") - (check-true (complete-path? (quad-ref (car (complete-attr-paths qs)) :ps))) - (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))) - (check-equal? (quad-ref (car (convert-numeric-attr-values qs)) :num) 42.5))) \ No newline at end of file +(define-syntax-rule (define-attr-list LIST-NAME + [ATTR-NAME ATTR-EXPR] ...) + (begin + (define ATTR-NAME ATTR-EXPR) ... + (define LIST-NAME + (let ([names (list ATTR-NAME ...)]) + (cond + [(check-duplicates (map attr-key-name names)) + => + (λ (sym) (raise-user-error 'define-attr-list "duplicate attribute name: ~a" sym))] + [else names]))))) + +(define-attr-list all-attr-keys + [: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-features (make-attr-set-key 'font-features #true default-no-features)] + [:font-features-add (make-attr-set-key 'font-features-add #false default-no-features)] + [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)] + + [:page-size (make-attr-uncased-string-key 'page-size #true default-page-size)] + [:page-orientation (make-attr-uncased-string-key 'page-orientation #true default-page-orientation)] + [:page-width (make-attr-dimension-string-key 'page-width)] + [:page-height (make-attr-dimension-string-key 'page-height)] + ) \ No newline at end of file diff --git a/quad2/constants.rkt b/quad2/constants.rkt index 2ea31c97..50b81cb5 100644 --- a/quad2/constants.rkt +++ b/quad2/constants.rkt @@ -1,7 +1,5 @@ #lang racket/base -(require racket/list - racket/set - "struct.rkt") +(require racket/set) (provide (all-defined-out)) (define default-font-family "text") @@ -13,31 +11,3 @@ (struct no-value ()) (define no-value-signal (no-value)) -(define-syntax-rule (define-attr-list LIST-NAME - [ATTR-NAME ATTR-EXPR] ...) - (begin - (define ATTR-NAME ATTR-EXPR) ... - (define LIST-NAME - (let ([names (list ATTR-NAME ...)]) - (cond - [(check-duplicates (map attr-key-name names)) - => - (λ (sym) (raise-user-error 'define-attr-list "duplicate attribute name: ~a" sym))] - [else names]))))) - -(define-attr-list all-attr-keys - [: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-features (make-attr-set-key 'font-features #true default-no-features)] - [:font-features-add (make-attr-set-key 'font-features-add #false default-no-features)] - [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)] - - [:page-size (make-attr-uncased-string-key 'page-size #true default-page-size)] - [:page-orientation (make-attr-uncased-string-key 'page-orientation #true default-page-orientation)] - [:page-width (make-attr-dimension-string-key 'page-width)] - [:page-height (make-attr-dimension-string-key 'page-height)] - ) \ No newline at end of file diff --git a/quad2/draw.rkt b/quad2/draw.rkt index 404f0669..926f67f9 100644 --- a/quad2/draw.rkt +++ b/quad2/draw.rkt @@ -1,13 +1,11 @@ #lang debug racket/base -(require racket/list - racket/string +(require racket/string racket/format racket/match + "attr.rkt" "quad.rkt" "pipeline.rkt" - "struct.rkt" - "layout.rkt" - "constants.rkt") + "struct.rkt") (provide (all-defined-out)) (define-pass (make-drawing-insts qs) diff --git a/quad2/font.rkt b/quad2/font.rkt index a8034d84..d7b4f4d6 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -5,16 +5,15 @@ racket/list racket/set racket/string - fontland/font-path + "attr.rkt" "quad.rkt" "constants.rkt" "pipeline.rkt" "param.rkt" "struct.rkt" - "dimension.rkt" - "attr.rkt" + "attr-passes.rkt" "glyphrun.rkt" - (prefix-in unicode: (combine-in "unicode/emoji.rkt" "unicode/math.rkt"))) + (prefix-in unicode: (combine-in "unicode/emoji.rkt"))) (provide (all-defined-out)) (define-runtime-path quad2-fonts-dir "default-fonts") diff --git a/quad2/main.rkt b/quad2/main.rkt index df682e02..7b05a842 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -6,6 +6,7 @@ "layout.rkt" "draw.rkt" "attr.rkt" + "attr-passes.rkt" "font.rkt" "constants.rkt" "param.rkt" diff --git a/quad2/page.rkt b/quad2/page.rkt index 4f108bb3..27506df2 100644 --- a/quad2/page.rkt +++ b/quad2/page.rkt @@ -1,6 +1,7 @@ #lang debug racket/base (require "quad.rkt" "attr.rkt" + "attr-passes.rkt" "pipeline.rkt" "constants.rkt" "param.rkt" diff --git a/quad2/param.rkt b/quad2/param.rkt index 98365144..5b2c29fc 100644 --- a/quad2/param.rkt +++ b/quad2/param.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/match "constants.rkt" + "attr.rkt" "struct.rkt") (provide (all-defined-out))