From cb45bea4c97e015dbba96e311fae6810962eee3e Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Mon, 17 Feb 2020 00:16:44 +0100
Subject: [PATCH] auto-hash-ref/: : Add.

---
 utils-tests.rkt | 12 +++++++++++-
 utils.rkt       | 47 +++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 56 insertions(+), 3 deletions(-)

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