some more pipeline pieces

quad2/attr.rkt

@@ -20,13 +20,13 @@
       [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)
 
 (define-pass (upgrade-attr-keys qs)
@@ -35,26 +35,26 @@
   #:pre (list-of quad?)
   #:post (list-of quad?)
   (define attr-lookup-table (for/hasheq ([a (in-list (current-attrs))])
-                              (values (attr-name a) a)))
+                                        (values (attr-name a) a)))
   (define attrs-seen (make-hasheq))
-  (define strict-attrs? (current-strict-attrs))
+  (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)))
+       (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)
@@ -71,8 +71,24 @@
                      #:which-attr attr-cased-string?
                      #:value-proc (λ (val attrs) (string-downcase val))))
 
-;; TODO: make real `takes-path?`
-(define (takes-path? x) (memq x '(ps)))
+
+(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]))))
+
+(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)))))
 
 (define-pass (complete-attr-paths qs)
   #:pre (list-of quad?)
@@ -98,19 +114,29 @@
   (define-attr-list debug-attrs
     [:foo (attr-cased-string 'foo)]
     [:ps (attr-path 'ps)]
-    [:dim (attr-dimension-string 'dim)])
+    [:dim (attr-dimension-string 'dim)]
+    [:boolt (attr-boolean 'bool)]
+    [:boolf (attr-boolean 'bool)]
+    [:num (attr-numeric 'num)])
   (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")))))
+                                                    (cons :dim "2in")
+                                                    (cons :boolt "true")
+                                                    (cons :boolf "false")
+                                                    (cons :num "42.5")))))
     (define qs (list q))
     (check-not-exn (λ ()
-                     (parameterize ([current-strict-attrs #false])
+                     (parameterize ([current-strict-attrs? #false])
                        (upgrade-attr-keys qs))))
     (check-exn exn? (λ ()
-                     (parameterize ([current-strict-attrs #true])
-                       (upgrade-attr-keys qs))))
+                      (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)))
+    (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)))

quad2/main.rkt

@@ -45,12 +45,12 @@
                     ;; 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
+                    convert-boolean-attr-values
+                    convert-numeric-attr-values
 
                     ;; 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
@@ -69,12 +69,12 @@
 
 (define insts (parameterize ([current-wrap-width 13]
                              [current-attrs all-attrs]
-                             [current-strict-attrs #true]
-                             [show-timing #f])
+                             [current-strict-attrs? #t]
+                             [current-show-timing? #f]
+                             [current-use-preconditions? #t]
+                             [current-use-postconditions? #t])
                 (quad-compile "Hello this is the earth")))
 
-(displayln insts)
-
 (when (string? insts)
   (render insts #:using text-renderer)
   (render insts #:using drr-renderer)

quad2/param.rkt

@@ -3,14 +3,18 @@
          "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-syntax-rule (define-guarded-parameters [ID PRED STARTING-VALUE] ...)
+  (begin
+    (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)
+(define-guarded-parameters
+  [current-attrs (λ (xs) (and (list? xs) (andmap attr? xs))) null]
+  [current-show-timing? boolean? #false]
+  [current-strict-attrs? boolean? #false]
+  [current-use-preconditions? boolean? #true]
+  [current-use-postconditions? boolean? #true])

quad2/pipeline.rkt

@@ -14,11 +14,11 @@
   #:property prop:procedure
   (λ args
     (match-define (list* pipeline pass-arg _) args)
-    (let ([show-timing (show-timing)])
+    (let ([show-timing? (current-show-timing?)])
       (for/fold ([pass-arg pass-arg])
                 ([pass (in-list (pipeline-passes pipeline))])
         (define thunk (λ () (pass pass-arg)))
-        (if show-timing
+        (if show-timing?
             (time (displayln pass) (thunk))
             (thunk))))))
 
@@ -37,10 +37,12 @@
            (procedure-rename
             #,(syntax/loc stx
                 (λ (ARG OTHER-ARG ...)
-                  (unless (PRECOND-PROC ARG)
-                    (raise-argument-error 'PASS-NAME (format "~a" 'PRECOND-PROC) ARG))
+                  (when (current-use-preconditions?)
+                    (unless (PRECOND-PROC ARG)
+                      (raise-argument-error 'PASS-NAME (format "~a" 'PRECOND-PROC) ARG)))
                   (define res (let () EXPRS ...))
+                  (when (current-use-postconditions?)
                   (unless (POSTCOND-PROC res)
-                    (raise-argument-error 'PASS-NAME (format "~a" 'POSTCOND-PROC) res))
+                    (raise-argument-error 'PASS-NAME (format "~a" 'POSTCOND-PROC) res)))
                   res))
             'PASS-NAME))))]))