From ce02eca9799c091a6f6308d39acca25ff7586fa5 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 6 Apr 2022 13:15:41 -0700 Subject: [PATCH] improve iteration handle flat list or tree --- quad2/attr.rkt | 117 +++++++++++++++++++++++--------------------- quad2/font.rkt | 10 ++-- quad2/linearize.rkt | 28 ++++++----- quad2/main.rkt | 82 +++++++++++++++++-------------- quad2/pipeline.rkt | 2 +- 5 files changed, 126 insertions(+), 113 deletions(-) diff --git a/quad2/attr.rkt b/quad2/attr.rkt index 672050c7..55224774 100644 --- a/quad2/attr.rkt +++ b/quad2/attr.rkt @@ -3,6 +3,7 @@ racket/hash racket/list racket/string + racket/set "dimension.rkt" "pipeline.rkt" "struct.rkt" @@ -11,22 +12,28 @@ "param.rkt") (provide (all-defined-out)) -(define (do-attr-iteration qs #:which-attr which-arg #:value-proc proc) - (define key-predicate - (match which-arg - [(? attr? attr) (λ (k) (eq? k (attr-name attr)))] - [(and (list (? attr?) ...) attrs) (λ (k) (memq k (map attr-name attrs)))] - [(? procedure? pred) pred] +(define (do-attr-iteration qs + #:which-attr which-attr + #:attr-proc attr-proc) + (define attr-predicate + (match which-attr + [(? 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 (make-hasheq)) - (for ([q (in-list qs)]) - (define attrs (quad-attrs q)) - (hash-ref! attrs-seen attrs - (λ () - (for ([k (in-hash-keys attrs)] - #:when (key-predicate k)) - (hash-update! attrs k (λ (val) (proc val attrs)))) - #t))) + (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)) + (hash-set! attrs ak (attr-proc ak av attrs))) + (set-add! attrs-seen attrs)) + (loop (quad-elems q))))) qs) (define-pass (upgrade-attr-keys qs) @@ -35,27 +42,23 @@ #:pre (list-of quad?) #:post (list-of quad?) (define attr-lookup-table (for/hasheq ([a (in-list (current-attrs))]) - (values (attr-name a) a))) - (define attrs-seen (make-hasheq)) + (values (attr-key-name a) a))) + (define attrs-seen (mutable-seteq)) (define strict-attrs? (current-strict-attrs?)) - (for ([q (in-list qs)]) - (define attrs (quad-attrs q)) - (hash-ref! attrs-seen attrs - (λ () - (for ([(k v) (in-hash attrs)] - #:unless (attr? k)) - (cond - [(symbol? k) - (match (hash-ref attr-lookup-table k #false) - [(? attr? attr) - (hash-remove! attrs k) - (hash-set! attrs attr v)] - [_ #:when strict-attrs? - (raise-argument-error 'upgrade-attr-keys "known attr" k)] - [_ (void)])] - [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" k)])) - #t))) - qs) + (define (do-upgrade ak av attrs) + (cond + [(symbol? ak) + (match (hash-ref attr-lookup-table ak #false) + [(? attr-key? attr) + (hash-remove! attrs ak) + (hash-set! attrs attr av)] + [_ #:when strict-attrs? + (raise-argument-error 'upgrade-attr-keys "known attr" ak)] + [_ (void)])] + [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)])) + (do-attr-iteration qs + #:which-attr (λ (ak) (not (attr-key? ak))) + #:attr-proc do-upgrade)) (define-pass (downcase-attr-values qs) ;; make attribute values lowercase, unless they're case-sensitive @@ -68,27 +71,29 @@ #:pre (list-of quad?) #:post (list-of quad?) (do-attr-iteration qs - #:which-attr attr-cased-string? - #:value-proc (λ (val attrs) (string-downcase val)))) + #: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? - #:value-proc (λ (val attrs) (match (string-downcase val) - ["false" #false] - [_ #true])))) + #:which-attr attr-boolean-key? + #:attr-proc (λ (ak av attrs) (match (string-downcase av) + ["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? - #:value-proc (λ (val attrs) - (or (string->number val) - (raise-argument-error 'convert-numeric-attr-values "numeric string" val))))) + #:which-attr attr-numeric-key? + #:attr-proc (λ (ak av attrs) + (cond + [(string->number av)] + [else + (raise-argument-error 'convert-numeric-attr-values "numeric string" av)])))) (define-pass (complete-attr-paths qs) #:pre (list-of quad?) @@ -97,8 +102,8 @@ ;; 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? - #:value-proc (λ (val attrs) (path->complete-path val)))) + #:which-attr attr-path-key? + #:attr-proc (λ (ak av attrs) (path->complete-path av)))) (define-pass (parse-dimension-strings qs) #:pre (list-of quad?) @@ -106,18 +111,18 @@ ;; 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? - #:value-proc parse-dimension)) + #:which-attr attr-dimension-string-key? + #:attr-proc (λ (ak av attrs) (parse-dimension av attrs)))) (module+ test (require rackunit) (define-attr-list debug-attrs - [:foo (attr-cased-string 'foo)] - [:ps (attr-path 'ps)] - [:dim (attr-dimension-string 'dim)] - [:boolt (attr-boolean 'bool)] - [:boolf (attr-boolean 'bool)] - [:num (attr-numeric 'num)]) + [: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)]) (parameterize ([current-attrs debug-attrs]) (define q (make-quad #:attrs (make-hasheq (list (cons :foo "BAR") (cons 'ding "dong") @@ -134,7 +139,7 @@ (parameterize ([current-strict-attrs? #true]) (upgrade-attr-keys qs)))) (check-equal? (quad-ref (car (downcase-attr-values qs)) :foo) "bar") - (check-true (complete-path? (string->path (quad-ref (car (complete-attr-paths qs)) :ps)))) + (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)) diff --git a/quad2/font.rkt b/quad2/font.rkt index 45cafa36..e8eb4de6 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -118,12 +118,12 @@ ;; 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 (attr-name :font-family) default-font-family)) + (define this-font-family (hash-ref! attrs (attr-key-name :font-family) default-font-family)) (match (string-downcase this-font-family) [(? font-path-string? ps) (path->complete-path ps)] [_ - (define this-bold (hash-ref! attrs (attr-name :font-bold) #false)) - (define this-italic (hash-ref! attrs (attr-name :font-italic) #false)) + (define this-bold (hash-ref! attrs (attr-key-name :font-bold) #false)) + (define this-italic (hash-ref! attrs (attr-key-name :font-italic) #false)) (font-attrs->path font-paths this-font-family this-bold this-italic)])) (define-pass (resolve-font-paths qs) @@ -135,12 +135,12 @@ (define font-paths (setup-font-path-table)) (do-attr-iteration qs #:which-attr :font-family - #:value-proc (λ (val attrs) (resolve-font-path font-paths val attrs)))) + #:attr-proc (λ (ak av attrs) (resolve-font-path font-paths av attrs)))) (module+ test (require rackunit) (define-attr-list debug-attrs - [:font-family (attr-uncased-string 'font-family)]) + [:font-family (attr-uncased-string-key 'font-family)]) (parameterize ([current-attrs debug-attrs]) (define (resolved-font-for-family val #:bold [bold #f] #:italic [italic #f]) (define qs (list (make-quad #:attrs (make-hasheq diff --git a/quad2/linearize.rkt b/quad2/linearize.rkt index 32c38979..c1c5f21e 100644 --- a/quad2/linearize.rkt +++ b/quad2/linearize.rkt @@ -9,25 +9,27 @@ (define (simple-quad? x) (and (quad? x) (<= (length (quad-elems x)) 1))) -(define-pass (linearize-quad q) +(define-pass (linearize qs) ;; convert a single quad into a list of quads, with the attributes propagated downward ;; every resulting quad should have at most one element - #:pre quad? + #:pre (list-of quad?) #:post (list-of simple-quad?) - (let loop ([q q][attrs-context (make-quad-attrs)]) ;; returns (list-of quad?) - (define current-attrs (quad-attrs-union attrs-context (quad-attrs q))) - (define (mq es) (make-quad #:tag (quad-tag q) #:attrs current-attrs #:elems es)) - (match (quad-elems q) - [(? null?) (list (mq null))] - [(? pair? elems) - (apply append (for/list ([e (in-list elems)]) - (cond - [(quad? e) (loop e current-attrs)] - [else (list (mq (list e)))])))]))) + (append* + (for/list ([q (in-list qs)]) + (let loop ([q q][attrs-context (make-quad-attrs)]) ;; returns (list-of quad?) + (define current-attrs (quad-attrs-union attrs-context (quad-attrs q))) + (define (mq es) (make-quad #:tag (quad-tag q) #:attrs current-attrs #:elems es)) + (match (quad-elems q) + [(? null?) (list (mq null))] + [(? pair? elems) + (apply append (for/list ([e (in-list elems)]) + (cond + [(quad? e) (loop e current-attrs)] + [else (list (mq (list e)))])))]))))) (module+ test (define q (make-quad #:attrs (hasheq 'foo 42) #:elems (list (make-quad #:elems (list "Hi" " idiot" (make-quad #:attrs (hasheq 'bar 84) #:elems '("There")) " Eve" "ry" "one" (make-quad #:attrs (hasheq 'zam 108) #:elems null)))))) - (define lqs (linearize-quad q)) + (define lqs (linearize (list q))) lqs) diff --git a/quad2/main.rkt b/quad2/main.rkt index 1b70da11..0ed36ae0 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -12,60 +12,66 @@ "constants.rkt" "param.rkt" racket/string + racket/list racket/match) (define-pass (bootstrap-input x) ;; turn a simple string into a quad for testing layout. #:pre string? - #:post quad? - (match x - [(or (? quad? q) (list (? quad? q))) q] - [(and (list (? quad?) ...) qs) (make-quad #:elems qs)] - [other (make-quad #:elems (list other))])) + #:post (list-of quad?) + (list (match x + [(or (? quad? q) (list (? quad? q))) q] + [(and (list (? quad?) ...) qs) (make-quad #:elems qs)] + [other (make-quad #:elems (list other))]))) (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?) - (apply 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)])))) + (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 - bootstrap-input - linearize-quad + ;; attribute prep ============= + ;; all attrs start out as symbol-string pairs. + ;; we convert keys & values to corresponding higher-level types. + upgrade-attr-keys + downcase-attr-values + convert-boolean-attr-values + convert-numeric-attr-values + ;; we resolve dimension strings after font size + ;; because they can be denoted relative to em size + parse-dimension-strings - ;; attribute sanitizing ============= - ;; all attrs start out as symbol-string pairs. - ;; we convert keys & values to corresponding higher-level types. - upgrade-attr-keys - downcase-attr-values - convert-boolean-attr-values - convert-numeric-attr-values + ;; linearization ============= + ;; we postpone this step until we're certain any + ;; information encoded from the hierarchy of quads + ;; has been absorbed into the attrs + ;; (e.g., cascading font sizes) + ;; because once we linearize, that information is gone. + linearize - ;; resolutions & parsings ============= - resolve-font-paths - complete-attr-paths - ;; TODO: resolve font sizes - ;; we resolve dimension strings after font size - ;; because they can be denoted relative to em size - parse-dimension-strings - ;; TODO: parse feature strings + ;; resolutions & parsings ============= + resolve-font-paths + complete-attr-paths + ;; TODO: resolve font sizes + ;; TODO: parse feature strings - mark-text-runs - merge-adjacent-strings - split-whitespace - split-into-single-char-quads - ;; TODO: missing glyphs - layout - make-drawing-insts - stackify))) + mark-text-runs + merge-adjacent-strings + split-whitespace + split-into-single-char-quads + ;; TODO: missing glyphs + layout + make-drawing-insts + stackify))) (define insts (parameterize ([current-wrap-width 13] [current-attrs all-attrs] @@ -73,7 +79,7 @@ [current-show-timing? #f] [current-use-preconditions? #t] [current-use-postconditions? #t]) - (quad-compile "Hello this is the earth"))) + (quad-compile (bootstrap-input "Hello this is the earth")))) (when (string? insts) (render insts #:using text-renderer) diff --git a/quad2/pipeline.rkt b/quad2/pipeline.rkt index 72af49c9..e4bbc7a0 100644 --- a/quad2/pipeline.rkt +++ b/quad2/pipeline.rkt @@ -36,7 +36,7 @@ (list (procedure-rename #,(syntax/loc stx - (λ (ARG OTHER-ARG ...) + (λ (ARG) (when (current-use-preconditions?) (unless (PRECOND-PROC ARG) (raise-argument-error 'PASS-NAME (format "~a (as precondition)" 'PRECOND-PROC) ARG)))