make language-info compose nicely
This commit is contained in:
parent
d0029ed1f5
commit
a93f583fc4
|
@ -2,9 +2,20 @@
|
|||
|
||||
(provide get-language-info)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(define (get-language-info data)
|
||||
(define other-get-info
|
||||
(match data
|
||||
[(vector mod sym data2)
|
||||
((dynamic-require mod sym) data2)]
|
||||
[_ (lambda (key default) default)]))
|
||||
(lambda (key default)
|
||||
(case key
|
||||
[(configure-runtime)
|
||||
'(#[afl/lang/runtime-config configure #f])]
|
||||
[else default])))
|
||||
(define config-vec '#[afl/lang/runtime-config configure #f])
|
||||
(define other-config (other-get-info key default))
|
||||
(cond [(list? other-config) (cons config-vec other-config)]
|
||||
[else (list config-vec)])]
|
||||
[else (other-get-info key default)])))
|
||||
|
||||
|
|
|
@ -23,9 +23,10 @@
|
|||
(lambda (orig-read-syntax)
|
||||
(define read-syntax (wrap-reader orig-read-syntax))
|
||||
(lambda args
|
||||
(syntax-property (apply read-syntax args)
|
||||
'module-language
|
||||
'#(afl/lang/language-info get-language-info #f))))
|
||||
(define stx (apply read-syntax args))
|
||||
(define old-prop (syntax-property stx 'module-language))
|
||||
(define new-prop `#(afl/lang/language-info get-language-info ,old-prop))
|
||||
(syntax-property stx 'module-language new-prop)))
|
||||
(lambda (proc)
|
||||
(lambda (key defval)
|
||||
(define (fallback) (if proc (proc key defval) defval))
|
||||
|
|
|
@ -5,8 +5,5 @@
|
|||
(require (only-in afl/reader make-afl-readtable))
|
||||
|
||||
(define (configure data)
|
||||
(define old-read (current-read-interaction))
|
||||
(define (new-read src in)
|
||||
(parameterize ([current-readtable (make-afl-readtable (current-readtable))])
|
||||
(old-read src in)))
|
||||
(current-read-interaction new-read))
|
||||
(current-readtable (make-afl-readtable)))
|
||||
|
||||
|
|
|
@ -121,9 +121,10 @@
|
|||
[%1 (string->id stx* arg-str "1")]
|
||||
[body stx*])
|
||||
(intro
|
||||
#'(lambda args
|
||||
(syntax/loc stx
|
||||
(lambda args
|
||||
(define-syntax % (make-rename-transformer #'%1))
|
||||
body)))))
|
||||
body))))))
|
||||
|
||||
(module+ test
|
||||
;; These test `parse`. See test.rkt for tests of readtable use per se.
|
||||
|
|
Loading…
Reference in New Issue
Block a user