typesetting/quad2/attr.rkt

#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))

(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)))