From ddc3a030d70263c37ce3f528dc6dd0486ab7ecd0 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 4 Apr 2022 13:48:30 -0700 Subject: [PATCH] introduce typed attrs --- quad2/attr.rkt | 89 ++++++++++++++++++++++++++++++++------------- quad2/constants.rkt | 15 ++++++++ quad2/font.rkt | 53 ++++++++++++++------------- quad2/main.rkt | 68 ++++++++++++++++++---------------- quad2/param.rkt | 16 ++++++++ quad2/pipeline.rkt | 11 +++++- quad2/struct.rkt | 10 ++++- 7 files changed, 178 insertions(+), 84 deletions(-) create mode 100644 quad2/constants.rkt create mode 100644 quad2/param.rkt diff --git a/quad2/attr.rkt b/quad2/attr.rkt index 61df2d31..e8b2ced8 100644 --- a/quad2/attr.rkt +++ b/quad2/attr.rkt @@ -5,29 +5,57 @@ racket/string "dimension.rkt" "pipeline.rkt" - "quad.rkt") + "struct.rkt" + "constants.rkt" + "quad.rkt" + "param.rkt") (provide (all-defined-out)) -(define (do-attr-iteration qs #:which-key which-arg #:value-proc proc) +(define (do-attr-iteration qs #:which-attr which-arg #:value-proc proc) (define key-predicate (match which-arg - [(? symbol? sym) (λ (k) (eq? k sym))] - [(and (list (? symbol?) ...) syms) (λ (k) (memq k syms))] + [(? attr? attr) (λ (k) (eq? k (attr-name attr)))] + [(and (list (? attr?) ...) attrs) (λ (k) (memq k (map attr-name attrs)))] [(? procedure? pred) 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 (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))) qs) -;; TODO: make real `has-case-sensitive-value?` -(define (has-case-sensitive-value? x) #false) +(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-name a) a))) + (define attrs-seen (make-hasheq)) + (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-pass (downcase-attr-values qs) ;; make attribute values lowercase, unless they're case-sensitive @@ -40,7 +68,7 @@ #:pre (list-of quad?) #:post (list-of quad?) (do-attr-iteration qs - #:which-key (λ (k) (not (has-case-sensitive-value? k))) + #:which-attr attr-cased-string? #:value-proc (λ (val attrs) (string-downcase val)))) ;; TODO: make real `takes-path?` @@ -53,25 +81,36 @@ ;; 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-key takes-path? + #:which-attr attr-path? #:value-proc (λ (val attrs) (path->string (path->complete-path val))))) -;; TODO: make real `takes-dimension-string?` -(define (takes-dimension-string? x) (memq x '(dim))) - (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-key takes-dimension-string? - #:value-proc (λ (val attrs) (parse-dimension val attrs)))) + #:which-attr attr-dimension-string? + #:value-proc parse-dimension)) (module+ test (require rackunit) - (define q (make-quad #:attrs (make-hasheq '((foo . "BAR")(ps . "file.txt")(dim . "2in"))))) - (define qs (list q)) - (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-equal? (quad-ref (car (parse-dimension-strings qs)) 'dim) 144)) \ No newline at end of file + (define-attr-list debug-attrs + [:foo (attr-cased-string 'foo)] + [:ps (attr-path 'ps)] + [:dim (attr-dimension-string 'dim)]) + (parameterize ([current-attrs debug-attrs]) + (define q (make-quad #:attrs (make-hasheq (list (cons :foo "BAR") + (cons 'ding "dong") + (cons :ps "file.txt") + (cons :dim "2in"))))) + (define qs (list q)) + (check-not-exn (λ () + (parameterize ([current-strict-attrs #false]) + (upgrade-attr-keys qs)))) + (check-exn exn? (λ () + (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-equal? (quad-ref (car (parse-dimension-strings qs)) :dim) 144))) \ No newline at end of file diff --git a/quad2/constants.rkt b/quad2/constants.rkt new file mode 100644 index 00000000..3ee74733 --- /dev/null +++ b/quad2/constants.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require "struct.rkt") +(provide (all-defined-out)) + +(define-syntax-rule (define-attr-list LIST-NAME + [ATTR-NAME ATTR-EXPR] ...) + (begin + (define ATTR-NAME ATTR-EXPR) ... + (define LIST-NAME (list ATTR-NAME ...)))) + +(define-attr-list all-attrs + [:font-family (attr-uncased-string 'font-family)] + [:font-path (attr-path 'font-path)] + [:font-bold (attr-boolean 'font-bold)] + [:font-italic (attr-boolean 'font-italic)]) \ No newline at end of file diff --git a/quad2/font.rkt b/quad2/font.rkt index 7313d90d..45cafa36 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -6,15 +6,13 @@ racket/string fontland/font-path "quad.rkt" + "constants.rkt" "pipeline.rkt" + "param.rkt" + "struct.rkt" "attr.rkt") (provide (all-defined-out)) -(define :font-family 'font-family) -(define :font-path 'font-path) -(define :font-bold 'font-bold) -(define :font-italic 'font-italic) - (define-runtime-path quad2-fonts-dir "default-fonts") (define-runtime-path default-font-face "default-fonts/default/SourceSerifPro-Regular.otf") (define top-font-directory "fonts") @@ -97,14 +95,13 @@ ;; and fall through to the default font when we do the `cond` below. ;; TODO: family->path doesn't work because it relies on ffi into fontconfig ;; which has broken in cs, I guess - #| -(unless (hash-has-key? font-paths regular-key) - (for* ([bold (in-list (list #false #true))] - [italic (in-list (list #false #true))]) - (hash-set! font-paths - (make-key font-family bold italic) - (family->path font-family #:bold bold #:italic italic)))) -|# + #;(unless (hash-has-key? font-paths regular-key) + (display "(fontconfig lookup unimplemented)") + #;(for* ([bold (in-list (list #false #true))] + [italic (in-list (list #false #true))]) + (hash-set! font-paths + (make-key font-family bold italic) + (family->path font-family #:bold bold #:italic italic)))) (cond [(hash-ref font-paths (make-key font-family bold italic) #false)] ;; try regular style if style-specific key isn't there for b i or bi @@ -121,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 :font-family default-font-family)) + (define this-font-family (hash-ref! attrs (attr-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 :font-bold #false)) - (define this-italic (hash-ref! attrs :font-italic #false)) + (define this-bold (hash-ref! attrs (attr-name :font-bold) #false)) + (define this-italic (hash-ref! attrs (attr-name :font-italic) #false)) (font-attrs->path font-paths this-font-family this-bold this-italic)])) (define-pass (resolve-font-paths qs) @@ -137,17 +134,21 @@ #:post (list-of quad?) (define font-paths (setup-font-path-table)) (do-attr-iteration qs - #:which-key :font-family + #:which-attr :font-family #:value-proc (λ (val attrs) (resolve-font-path font-paths val attrs)))) (module+ test (require rackunit) - (define q (make-quad #:attrs (make-hasheq '((font-family . "Heading"))))) - (define qs (list q)) - (define (resolved-font-for-family val #:bold [bold #f] #:italic [italic #f]) - (last (explode-path (quad-ref (car (resolve-font-paths (list (make-quad #:attrs (make-hasheq (list (cons :font-family val) (cons :font-bold bold) - (cons :font-italic italic))))))) :font-family)))) - (check-equal? (resolved-font-for-family "Heading") (string->path "fira-sans-light.otf")) - (check-equal? (resolved-font-for-family "CODE") (string->path "fira-mono.otf")) - (check-equal? (resolved-font-for-family "blockquote" #:bold #t) (string->path "fira-sans-bold.otf")) - (check-equal? (resolved-font-for-family "nonexistent-fam") (string->path "SourceSerifPro-Regular.otf"))) \ No newline at end of file + (define-attr-list debug-attrs + [:font-family (attr-uncased-string '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 + (list (cons 'font-family (string-downcase val)) + (cons 'font-bold bold) + (cons 'font-italic italic)))))) + (last (explode-path (quad-ref (car (resolve-font-paths qs)) 'font-family)))) + (check-equal? (resolved-font-for-family "Heading") (string->path "fira-sans-light.otf")) + (check-equal? (resolved-font-for-family "CODE") (string->path "fira-mono.otf")) + (check-equal? (resolved-font-for-family "blockquote" #:bold #t) (string->path "fira-sans-bold.otf")) + (check-equal? (resolved-font-for-family "nonexistent-fam") (string->path "SourceSerifPro-Regular.otf")))) \ No newline at end of file diff --git a/quad2/main.rkt b/quad2/main.rkt index 59055b7d..36f7df6b 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -9,6 +9,8 @@ "struct.rkt" "attr.rkt" "font.rkt" + "constants.rkt" + "param.rkt" racket/string racket/match) @@ -33,38 +35,42 @@ (struct-copy quad q [elems (list (string c))]))] [_ (list q)])))) -(define quad-compile (make-pipeline (list - bootstrap-input - linearize-quad - ;; TODO: maybe we shouldn't downcase values? - ;; we have to track attrs that are case sensitive - ;; instead we could use case-insensitive matching where suitable - ;; but will it always be apparent whether it's suitable? - ;; or will we have to still track which attrs are case-sensitive? - downcase-attr-values - ;; TODO: convert booleanized attrs - ;; TODO: convert numerical attrs - ;; upgrade relative paths to complete for ease of handling later - ;; TODO: we have to track which attrs take a path - ;; (to distinguish them from attrs that might have path-like values - ;; that should be left alone) - complete-attr-paths - resolve-font-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 - mark-text-runs - merge-adjacent-strings - split-whitespace - split-into-single-char-quads - ;; TODO: missing glyphs - layout - make-drawing-insts - stackify))) +(define quad-compile + (make-pipeline (list + bootstrap-input + linearize-quad -(define insts (parameterize ([current-wrap-width 13]) + ;; 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 + ;; TODO: convert booleanized attrs + ;; TODO: convert numerical attrs + complete-attr-paths + + ;; resolutions & parsings ============= + resolve-font-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 + + + 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] + [current-strict-attrs #true] + [show-timing #f]) (quad-compile "Hello this is the earth"))) (displayln insts) diff --git a/quad2/param.rkt b/quad2/param.rkt new file mode 100644 index 00000000..19bb6ecc --- /dev/null +++ b/quad2/param.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require racket/match + "struct.rkt") +(provide (all-defined-out)) + +(define-syntax-rule (define-guarded-parameter ID PRED STARTING-VALUE) + (define ID + (make-parameter STARTING-VALUE + (λ (val) + (unless (PRED val) + (raise-argument-error 'ID (format "~a" (object-name PRED)) val)) + val)))) + +(define-guarded-parameter current-attrs (λ (xs) (and (list? xs) (andmap attr? xs))) null) +(define-guarded-parameter show-timing boolean? #false) +(define-guarded-parameter current-strict-attrs boolean? #false) diff --git a/quad2/pipeline.rkt b/quad2/pipeline.rkt index 70309f58..122bc9e1 100644 --- a/quad2/pipeline.rkt +++ b/quad2/pipeline.rkt @@ -1,6 +1,7 @@ #lang debug racket/base (require racket/match (for-syntax racket/base) + "param.rkt" "quad.rkt") (provide (all-defined-out)) @@ -11,7 +12,15 @@ (raise-argument-error 'bad-input-to-compiler-constructor "list of procedures" procs)) procs) #:property prop:procedure - (λ args (apply (apply compose1 (reverse (pipeline-passes (car args)))) (cdr args)))) + (λ args + (match-define (list* pipeline pass-arg _) args) + (let ([show-timing (show-timing)]) + (for/fold ([pass-arg pass-arg]) + ([pass (in-list (pipeline-passes pipeline))]) + (define thunk (λ () (pass pass-arg))) + (if show-timing + (time (displayln pass) (thunk)) + (thunk)))))) (define (compiler-append c passes) (make-pipeline (append (pipeline-passes c) passes))) diff --git a/quad2/struct.rkt b/quad2/struct.rkt index dca95efa..ced8e30d 100644 --- a/quad2/struct.rkt +++ b/quad2/struct.rkt @@ -5,4 +5,12 @@ (struct $move $drawing-inst (posn) #:transparent) ; an absolute location in coordinate system (not relative to last loc) (struct $text $drawing-inst (charint) #:transparent) (struct $doc $drawing-inst (inst) #:transparent) -(struct $page $drawing-inst (inst) #:transparent) \ No newline at end of file +(struct $page $drawing-inst (inst) #:transparent) + +(struct attr (name) #:transparent) +(struct attr-uncased-string attr () #:transparent) +(struct attr-cased-string attr () #:transparent) +(struct attr-dimension-string attr () #:transparent) +(struct attr-path attr () #:transparent) +(struct attr-numeric attr () #:transparent) +(struct attr-boolean attr () #:transparent) \ No newline at end of file