introduce typed attrs

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

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

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

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)

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)

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

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