From 4f99f4d38a76ac7f49f0fbc44785b62197b6790c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 4 Apr 2022 15:16:54 -0700 Subject: [PATCH] some more pipeline pieces --- quad2/attr.rkt | 92 +++++++++++++++++++++++++++++----------------- quad2/main.rkt | 14 +++---- quad2/param.rkt | 24 +++++++----- quad2/pipeline.rkt | 12 +++--- 4 files changed, 87 insertions(+), 55 deletions(-) diff --git a/quad2/attr.rkt b/quad2/attr.rkt index e8b2ced8..f99f548e 100644 --- a/quad2/attr.rkt +++ b/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))) \ No newline at end of file + (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))) \ No newline at end of file diff --git a/quad2/main.rkt b/quad2/main.rkt index 36f7df6b..1b70da11 100644 --- a/quad2/main.rkt +++ b/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) diff --git a/quad2/param.rkt b/quad2/param.rkt index 19bb6ecc..dc123f4b 100644 --- a/quad2/param.rkt +++ b/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]) diff --git a/quad2/pipeline.rkt b/quad2/pipeline.rkt index 122bc9e1..9fd23412 100644 --- a/quad2/pipeline.rkt +++ b/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))))])) \ No newline at end of file