dds/utils.rkt
2020-12-06 22:28:45 +01:00

203 lines
6.4 KiB
Racket
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#lang typed/racket
(require (for-syntax syntax/parse racket/list))
(provide Symbol VariableMapping
eval-with eval1-with
extract-symbols
any->string stringify-variable-mapping string->any map-sexp
read-org-sexp unorg
;; Syntax
auto-hash-ref/explicit auto-hash-ref/:)
(module+ test
(require typed/rackunit))
;;; ===================
;;; HashTable injection
;;; ===================
(define-type Variable Symbol)
(define-type (VariableMapping A) (Immutable-HashTable Variable A))
(: eval-with (-> (VariableMapping Any) Any AnyValues))
(define (eval-with ht expr)
(parameterize ([current-namespace (make-base-namespace)])
(for ([(x val) (in-hash ht)]) (namespace-set-variable-value! x val))
(eval expr)))
(: eval1-with (-> (VariableMapping Any) Any Any))
(define (eval1-with ht expr)
(call-with-values (λ () (eval-with ht expr))
(λ args (car args))))
(module+ test
(test-case "eval-with"
(check-equal? (eval1-with (hash 'a 1 'b 2) '(+ a b 1))
4)
(define ht : (VariableMapping Integer) (hash 'a 1 'b 2))
(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)))
;;; ==============================
;;; Analysis of quoted expressions
;;; ==============================
;;; Produces a list of symbols appearing in the quoted expression
;;; passed in the first argument.
(: extract-symbols (-> Any (Listof Symbol)))
(define (extract-symbols form)
(: extract-rec (-> Any (Listof Any)))
(define (extract-rec form)
(match form
[(? symbol?) (list form)]
[(? list?)
(flatten (for/list : (Listof Any)
([x form])
(extract-symbols x)))]
[else '()]))
(cast (extract-rec form) (Listof Symbol)))
(module+ test
(test-case "extract-symbols"
(check-equal? (extract-symbols '(1 (2 3) x (y z 3)))
'(x y z))))
;;; =========================
;;; Org-mode interoperability
;;; =========================
(: any->string (-> Any String))
(define (any->string x)
(with-output-to-string (λ () (display x))))
(module+ test
(test-case "any->string"
(check-equal? (any->string 'a) "a")
(check-equal? (any->string '(a 1 (x y))) "(a 1 (x y))")
(check-equal? (any->string "hello") "hello")))
(: stringify-variable-mapping (-> (VariableMapping Any) (VariableMapping String)))
(define (stringify-variable-mapping ht)
(for/hash : (VariableMapping String)
([(key val) (in-hash ht)]) (values key (any->string val))))
(module+ test
(test-case "stringify-variable-mapping"
(define mp (stringify-variable-mapping #hash((a . (and a b)) (b . (not b)))))
(check-equal? (hash-ref mp 'a) "(and a b)")
(check-equal? (hash-ref mp 'b) "(not b)")))
(: string->any (-> String Any))
(define (string->any str)
(with-input-from-string str (λ () (read))))
(module+ test
(test-case "string->any"
(check-equal? (string->any "(or b (not a))") '(or b (not a)))
(check-equal? (string->any "14") 14)))
;;; Given a sexp, converts all "#f" to #f and "#t" to #t.
;;;
;;; When I read Org-mode tables, I pump them through a call to the
;;; prin1 because the elisp sexp seems incompatible with Racket. On
;;; the other hand, Racket Booleans seem to upset elisp a little, so
;;; prin1 wraps them in additional double quotes. This function
;;; removes those quotes.
(: handle-org-booleans (-> Any Any))
(define/match (handle-org-booleans datum)
[("#t") #t]
[("#f") #f]
[((? list?)) (map handle-org-booleans datum)]
[(_) datum])
(: map-sexp (-> (-> Any Any) Any Any))
(define (map-sexp func sexp)
(match sexp
[(? list?) (map ((curry map-sexp) func) sexp)]
[datum (func datum)]))
(module+ test
(test-case "map-sexp"
(check-equal? (map-sexp (λ (x) (add1 (cast x Number))) '(1 2 (4 10) 3))
'(2 3 (5 11) 4))))
(: read-org-sexp (-> String Any))
(define read-org-sexp
(compose ((curry map-sexp) (match-lambda
[(and (? string?) str) (string->any str)]
[x x]))
string->any))
(define unorg read-org-sexp)
(module+ test
(test-case "read-org-sexp"
(check-equal? (read-org-sexp "((\"a\" \"(and a b)\") (\"b\" \"(or b (not a))\"))")
'((a (and a b)) (b (or b (not a)))))
(check-equal? (unorg "(#t \"#t\" \"#t \" '(1 2 \"#f\"))")
'(#t #t #t '(1 2 #f)))))