auto-hash-ref/: : Add.

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

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