scolobb/dds
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Streamline and simplify auto-hash-ref/:.

Browse source
This commit is contained in:
Sergiu Ivanov 2022-02-20 18:27:36 +01:00
parent fa015870d0
commit 3918730e1a
1 changed files with 20 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
utils.rkt
View file

@ -67,15 +67,28 @@
(and (not a) b))
#f)))
;;; Helper functions for auto-hash-ref/:.
(begin-for-syntax
(define (colon? s)
(and (symbol? s)
(eq? (string-ref (symbol->string s) 0) #\:)))
(define (collect-colons datum)
(cond [(colon? datum) (list datum)]
[(list? datum)
(remove-duplicates (flatten (for/list ([el (in-list datum)])
(collect-colons el))))]
[else '()]))
(define (strip-colon s)
(string->symbol (substring (symbol->string s) 1))))
(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))]))
[(_ ht:id body:expr)
(define colons (collect-colons (syntax->datum stx)))
(define bindings (for/list ([key colons])
`[,key (hash-ref ,#'ht ',(strip-colon key))]))
(with-syntax ([bindings-stx (datum->syntax stx bindings)])
#'(let bindings-stx body))]))
(module+ test
(test-case "auto-hash-ref/:"
@ -88,30 +101,6 @@
(check-equal? (auto-hash-ref/: ht2 (+ :a (* 2 :b)))
5)))
;;; 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))))
(: extract-symbols (-> Any (Listof Symbol)))
(define (extract-symbols form)
(: extract-rec (-> Any (Listof Any)))