diff --git a/utils-tests.rkt b/utils-tests.rkt index 2ab79c4..23d3046 100644 --- a/utils-tests.rkt +++ b/utils-tests.rkt @@ -13,4 +13,14 @@ (let ([ht #hash((a . #t) (b . #f))]) (check-equal? (auto-hash-ref/explicit (ht a b) (and (not a) b)) - #f)))) + #f))) + + (test-case "auto-hash-ref/:" + (let ([ht #hash((x . #t) (y . #t) (t . #f))] + [z #t]) + (check-equal? (auto-hash-ref/: ht + (and :x (not :y) z (or (and :t) :x))) + #f)) + (let ([ht #hash((a . 1) (b . 2))]) + (check-equal? (auto-hash-ref/: ht (+ :a (* 2 :b))) + 5)))) diff --git a/utils.rkt b/utils.rkt index 7d27e18..d195730 100644 --- a/utils.rkt +++ b/utils.rkt @@ -4,9 +4,10 @@ ;;; Various utilities. -(require (for-syntax syntax/parse)) +(require (for-syntax syntax/parse) + (for-syntax racket/list)) -(provide auto-hash-ref/explicit) +(provide auto-hash-ref/explicit auto-hash-ref/:) ;;; HashTable Injection @@ -29,4 +30,46 @@ #`[#,x (hash-ref ht '#,x)]) body)])) +;;; Given an expression and a (HashTable Symbol a), looks up the +;;; symbols with a leading semicolon and binds them to the value they +;;; are associated to in the hash table. +;;; +;;; > (let ([ht #hash((a . 1) (b . 2))]) +;;; (auto-hash-ref/: ht (+ :a (* 2 :b)))) +;;; 5 +;;; +;;; Note that the symbol :a is matched to the key 'a in the hash +;;; table. +(define-syntax (auto-hash-ref/: stx) + (syntax-parse stx + [(_ ht:id body) + (let* ([names/: (collect-colons (syntax->datum #'body))]) + #`(let #,(for/list ([x names/:]) + ;; put x in the same context as body + #`[#,(datum->syntax #'body x) + (hash-ref ht '#,(strip-colon x))]) + body))])) +;;; The helper functions for auto-hash-ref/:. +(begin-for-syntax + ;; Collect all the symbols starting with a colon in datum. + (define (collect-colons datum) + (remove-duplicates + (flatten + (for/list ([token datum]) + (cond + [(symbol? token) + (let ([name (symbol->string token)]) + (if (eq? #\: (string-ref name 0)) + token + '()))] + [(list? token) + (collect-colons token)] + [else '()]))))) + + ;; Strip the leading colon off x. + (define (strip-colon x) + (let ([x-str (symbol->string x)]) + (if (eq? #\: (string-ref x-str 0)) + (string->symbol (substring x-str 1)) + x))))