You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/quad2/attr.rkt

168 lines
7.2 KiB
Racket

#lang debug racket/base
(require racket/match
racket/hash
racket/list
racket/string
racket/set
"dimension.rkt"
"pipeline.rkt"
"struct.rkt"
"constants.rkt"
"quad.rkt"
"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 '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)
(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
;; 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-attrs))])
(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 (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.
;; 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 (complete-attr-paths qs)
#:pre (list-of quad?)
#:post (list-of quad?)
;; convert every pathlike thing to a complete path (well, path string, because it's inside an attr)
;; 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) (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
(require rackunit)
(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 '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")
(cons :ps "file.txt")
(cons :dim "2in")
(cons :boolt "true")
(cons :boolf "false")
(cons :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 (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-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)))