Redex: added to-lw/stx
plus improved the redex docs slightly and Rackety
This commit is contained in:
parent
fbbb30f7b0
commit
b43e956c7b
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require scheme/contract
|
||||
(require racket/contract
|
||||
"private/pict.ss"
|
||||
"private/core-layout.ss"
|
||||
"private/loc-wrapper.ss"
|
||||
|
@ -108,8 +108,32 @@
|
|||
lw-column-span)
|
||||
|
||||
(provide to-lw
|
||||
to-lw/stx
|
||||
(struct-out lw))
|
||||
|
||||
(require (prefix-in lw/ct: "private/loc-wrapper-ct.rkt")
|
||||
(prefix-in lw/rt: "private/loc-wrapper-rt.rkt"))
|
||||
(define (to-lw/stx stx)
|
||||
(let loop ([stx (lw/ct:to-lw/proc stx)])
|
||||
(syntax-case stx (init-loc-wrapper make-lw add-spans list quote)
|
||||
[(make-lw arg ...)
|
||||
(apply make-lw (map loop (syntax->list #'(arg ...))))]
|
||||
[(init-loc-wrapper arg ...)
|
||||
(apply lw/rt:init-loc-wrapper (map loop (syntax->list #'(arg ...))))]
|
||||
[(add-spans arg ...)
|
||||
(apply lw/rt:add-spans (map loop (syntax->list #'(arg ...))))]
|
||||
[(list arg ...)
|
||||
(apply list (map loop (syntax->list #'(arg ...))))]
|
||||
[(quote arg)
|
||||
(syntax->datum #'arg)]
|
||||
[_
|
||||
(let ([x (syntax-e stx)])
|
||||
(unless (or (number? x)
|
||||
(string? x)
|
||||
(boolean? x))
|
||||
(error 'to-lw/stx "unk thing: ~s\n" (syntax->datum stx)))
|
||||
x)])))
|
||||
|
||||
(provide/contract
|
||||
[just-before (-> (or/c pict? string? symbol?) lw? lw?)]
|
||||
[just-after (-> (or/c pict? string? symbol?) lw? lw?)])
|
||||
|
|
|
@ -67,7 +67,8 @@
|
|||
#,quoted?)]
|
||||
[x
|
||||
(and (identifier? #'x)
|
||||
(or (term-fn? (syntax-local-value #'x (λ () #f)))
|
||||
(or (and (syntax-transforming?)
|
||||
(term-fn? (syntax-local-value #'x (λ () #f))))
|
||||
((is-term-fn?) #'x)))
|
||||
#`(make-lw
|
||||
'#,(syntax-e #'x)
|
||||
|
|
|
@ -339,7 +339,8 @@ bound to @racket['()].
|
|||
If @racket[redex-match] receives three arguments, it
|
||||
matches the pattern (in the language) against its third
|
||||
argument. If it matches, this returns a list of match
|
||||
structures describing the matches. If it fails, it returns
|
||||
structures describing the matches (see @racket[match?] and
|
||||
@racket[match-bindings]). If it fails, it returns
|
||||
@racket[#f].
|
||||
|
||||
If @racket[redex-match] receives only two arguments, it
|
||||
|
@ -2589,6 +2590,13 @@ the empty string and the @racket[x] in the typeset output.
|
|||
|
||||
}
|
||||
|
||||
@defproc[(to-lw/stx [stx syntax?]) lw?]{
|
||||
This is the runtime variant on @racket[to-lw]; it accepts a
|
||||
syntax object and returns the corresponding @racket[lw] structs.
|
||||
It only uses the location information in the syntax object,
|
||||
so metafunctions will not be rendered properly.
|
||||
}
|
||||
|
||||
@defproc[(render-lw (language/nts (or/c (listof symbol?) compiled-lang?))
|
||||
(lw lw?)) pict?]{
|
||||
|
||||
|
|
|
@ -49,10 +49,11 @@
|
|||
;
|
||||
|
||||
|
||||
(module lw-test mzscheme
|
||||
(module lw-test racket/base
|
||||
(require "test-util.ss"
|
||||
"../private/loc-wrapper.ss"
|
||||
"lw-test-util.ss")
|
||||
"lw-test-util.ss"
|
||||
(only-in "../pict.rkt" to-lw/stx))
|
||||
|
||||
(reset-count)
|
||||
|
||||
|
@ -286,5 +287,8 @@
|
|||
#t #f))
|
||||
0 0 0 3))
|
||||
|
||||
(test (normalize-lw (to-lw (a ((b)) c 1 #t)))
|
||||
(normalize-lw (to-lw/stx #'(a ((b)) c 1 #t))))
|
||||
|
||||
(print-tests-passed "lw-test.ss"))
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user