utils.rkt: Copy auto-hash-ref/explicit and auto-hash-ref/:

scribblings/utils.scrbl

@@ -69,6 +69,42 @@ Like @racket[eval-with], but returns only the first value computed by
 (let ([ht (hash 'a 1 'b 1)])
   (eval1-with ht '(+ b a 1)))
 ]}
+
+@defform[(auto-hash-ref/explicit stx)
+         #:contracts ([stx (VariableMapping A)])]{
+
+Given a @racket[VariableMapping] and a sequence of symbols, binds these symbols
+to the values they are associated with in the hash table, then puts the body in
+the context of these bindings.
+
+@examples[#:eval utils-evaluator
+(let ([ht #hash((a . 1) (b . 2))])
+  (auto-hash-ref/explicit (ht a b) (+ a (* 2 b))))
+]
+
+Note that only one expression can be supplied in the body.
+
+}
+
+@defform[(auto-hash-ref/: stx)
+	 #:contracts ([stx (VariableMapping A)])]{
+
+Given an expression and a @racket[VariableMapping], looks up the symbols with
+a leading semicolon and binds them to the value they are associated with in the
+hash table.
+
+@examples[#:eval utils-evaluator
+(let ([ht #hash((a . 1) (b . 2))])
+  (auto-hash-ref/: ht (+ :a (* 2 :b))))
+]
+
+Thus the symbol @racket[:a] is matched to the key @racket['a] in the
+hash table.
+
+Note that only one expression can be supplied in the body.
+
+}
+
 @section{Analysis of quoted expressions}
 
 @section{Org-mode interoperability}

utils-untyped.rkt

@@ -53,9 +53,7 @@
  ;; Contracts
  (contract-out [variable-mapping? contract?]
                [string-variable-mapping? contract?]
-               [general-pair/c (-> contract? contract? contract?)])
- ;; Syntax
- auto-hash-ref/explicit auto-hash-ref/:)
+               [general-pair/c (-> contract? contract? contract?)]))
 
 (module+ test
   (require rackunit))

utils.rkt

@@ -1,9 +1,11 @@
 #lang typed/racket
 
-(require)
+(require (for-syntax syntax/parse racket/list))
 
 (provide Symbol VariableMapping
-         eval-with eval1-with)
+         eval-with eval1-with
+         ;; Syntax
+         auto-hash-ref/explicit auto-hash-ref/:)
 
 (module+ test
   (require typed/rackunit))
@@ -34,3 +36,66 @@
     (define expr : Any '(+ a b 1))
     (check-equal? (eval1-with ht expr)
                   4)))
+
+(define-syntax (auto-hash-ref/explicit stx)
+  (syntax-parse stx
+    [(_ (ht:id xs:id ...) body:expr)
+     #`(let #,(for/list ([x (syntax->list #'(xs ...))])
+                #`[#,x (hash-ref ht '#,x)])
+         body)]))
+
+(module+ test
+  (test-case "auto-hash-ref/explicit"
+    (define mytable #hash((a . 3) (b . 4)))
+    (check-equal? (auto-hash-ref/explicit (mytable b a)
+                                          (* a b))
+                  12)
+    (define ht #hash((a . #t) (b . #f)))
+    (check-equal? (auto-hash-ref/explicit (ht a b)
+                                          (and (not a) b))
+                  #f)))
+
+(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))))
+
+(module+ test
+  (test-case "auto-hash-ref/:"
+    (define ht1 #hash((x . #t) (y . #t) (t . #f)))
+    (define z #t)
+    (check-equal? (auto-hash-ref/: ht1
+                                   (and :x (not :y) z (or (and :t) :x)))
+                  #f)
+    (define ht2 #hash((a . 1) (b . 2)))
+    (check-equal? (auto-hash-ref/: ht2 (+ :a (* 2 :b)))
+                  5)))