parent
a79266d421
commit
e2c2f9429c
@ -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)))
|
||||
@ -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)))
|
||||
(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)]
|
||||
)
|
||||
Loading…
Reference in New Issue