147 lines
4.8 KiB
Racket
147 lines
4.8 KiB
Racket
#lang racket
|
|
|
|
;;; dds/utils
|
|
|
|
;;; Various utilities.
|
|
|
|
(require (for-syntax syntax/parse)
|
|
(for-syntax racket/list))
|
|
|
|
(provide
|
|
;; Functions
|
|
(contract-out [eval-with (-> variable-mapping? any/c any)]
|
|
[extract-symbols (-> any/c list?)]
|
|
[variable-mapping? (-> any/c boolean?)]
|
|
[hash-pred (->* (hash?)
|
|
(#:key-pred any/c #:val-pred any/c)
|
|
boolean?)])
|
|
;; Syntax
|
|
auto-hash-ref/explicit auto-hash-ref/:)
|
|
|
|
;;; ===================
|
|
;;; HashTable Injection
|
|
;;; ===================
|
|
|
|
;;; This section of the file contains some utilities to streamline the
|
|
;;; usage of hash tables mapping symbols to values. The goal is
|
|
;;; essentially to avoid having to write explicit hash-ref calls.
|
|
|
|
;;; Checks whether dict is a hash table and whether its keys satisfy
|
|
;;; key-pred and its values satisfy val-pred. If either of the
|
|
;;; predicates is not supplied, it defaults to true. For example,
|
|
;;; (hash-pred dict) is equivalent to (hash dict).
|
|
(define/match (hash-pred dict
|
|
#:key-pred [key-pred (λ (_) #t)]
|
|
#:val-pred [val-pred (λ (_) #t)])
|
|
[((hash-table (keys vals) ...) key-pred val-pred)
|
|
(and (andmap key-pred keys) (andmap val-pred vals))]
|
|
[(_ _ _) #f])
|
|
|
|
;;; A variable mapping is a hash table mapping symbols to values.
|
|
(define (variable-mapping? dict) (hash-pred dict #:key-pred symbol?))
|
|
|
|
;;; Given a (HashTable Symbol a) and a sequence of symbols, binds
|
|
;;; these symbols to the values they are associated to in the hash
|
|
;;; table, then puts the body in the context of these bindings.
|
|
;;;
|
|
;;; > (let ([ht #hash((a . 1) (b . 2))])
|
|
;;; (auto-hash-ref/explicit (ht a b) (+ a (* 2 b))))
|
|
;;; 5
|
|
;;;
|
|
;;; Note that only one expression can be supplied in the body.
|
|
(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)]))
|
|
|
|
;;; 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.
|
|
;;;
|
|
;;; Note that only one expression can be supplied in the body.
|
|
(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))))
|
|
|
|
;;; Temporarily injects the mappings from the given hash table as
|
|
;;; bindings in a namespace including racket/base and then evaluates
|
|
;;; the expression.
|
|
;;;
|
|
;;; > (let ([ht #hash((a . 1) (b . 1))])
|
|
;;; (eval-with ht '(+ b a 1)))
|
|
;;; 3
|
|
;;;
|
|
;;; The local bindings from the current lexical scope are not
|
|
;;; conserved. Therefore, the following outputs an error about a
|
|
;;; missing identifier:
|
|
;;;
|
|
;;; > (let ([ht #hash((a . 1) (b . 1))]
|
|
;;; [z 1])
|
|
;;; (eval-with ht '(+ b z a 1)))
|
|
;;;
|
|
(define (eval-with ht expr)
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
|
(hash-for-each ht (lambda (x val)
|
|
(namespace-set-variable-value! x val)))
|
|
(eval expr)))
|
|
|
|
;;; Same as eval-with, but returns only the first value produced by
|
|
;;; the evaluated expression.
|
|
(define (eval-with1 ht expr)
|
|
(let ([vals (call-with-values (λ () (eval-with ht expr))
|
|
(λ vals vals))])
|
|
(car vals)))
|
|
|
|
|
|
;;; ==============================
|
|
;;; Analysis of quoted expressions
|
|
;;; ==============================
|
|
|
|
;;; Produces a list of symbols appearing in the quoted expression
|
|
;;; passed in the first argument.
|
|
(define (extract-symbols form)
|
|
(cond
|
|
[(symbol? form)
|
|
(list form)]
|
|
[(list? form)
|
|
(flatten (for/list ([x form]) (extract-symbols x)))]
|
|
[else '()]))
|