adjust beaucoup places in redex where the source was being
included in the compiled files. (also, misc minor cleanups notably a new exercise in tut.scrbl) closes PR 12547 --- there are still a few uses left, but they do not seem to be coming from Redex proper: - /Users/robby/git/plt/collects/racket/private/map.rkt still appears in a bunch of places (there is a separate PR for that I believe), and - /Users/robby/git/plt/collects/redex/../private/reduction-semantics.rkt appears in tl-test.rkt, but I do not see how it is coming in via Redex code, so hopefully one of the other PRs that Eli submitted is the real cause. If not, I'll revisit later
This commit is contained in:
parent
ed22a630fd
commit
55b3d99d78
|
@ -31,9 +31,9 @@
|
|||
(c--> (/ number_1 number_2)
|
||||
,(/ (term number_1) (term number_2))
|
||||
"divide")
|
||||
(c-->(sqrt number_1)
|
||||
,(sqrt (term number_1))
|
||||
"sqrt")
|
||||
(c--> (sqrt number_1)
|
||||
,(sqrt (term number_1))
|
||||
"sqrt")
|
||||
with
|
||||
[(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b))
|
||||
(c--> a b)]))
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
|
||||
(require redex/reduction-semantics
|
||||
racket/contract
|
||||
(for-syntax racket/base))
|
||||
(for-syntax racket/base
|
||||
setup/path-to-relative))
|
||||
|
||||
(define-struct test-suite (name reductions to-mz equal? tests))
|
||||
(define-struct test (name input expecteds run-mz? around file line))
|
||||
|
@ -71,22 +72,26 @@
|
|||
(syntax-case stx ()
|
||||
[(_ name term expected)
|
||||
(with-syntax ([line (syntax-line stx)]
|
||||
[source (syntax-source stx)])
|
||||
[source (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))])
|
||||
(syntax (build-test name term (list expected) #t #f line source)))]
|
||||
[(_ name term expected mz?)
|
||||
(with-syntax ([line (syntax-line stx)]
|
||||
[source (syntax-source stx)])
|
||||
[source (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))])
|
||||
(syntax (build-test name term (list expected) mz? #f line source)))]
|
||||
[(_ name term expected mz? around)
|
||||
(with-syntax ([line (syntax-line stx)]
|
||||
[source (syntax-source stx)])
|
||||
[source (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))])
|
||||
(syntax (build-test name term (list expected) mz? around line source)))]))
|
||||
|
||||
(define-syntax (test/anss stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name term expecteds)
|
||||
(with-syntax ([line (syntax-line stx)]
|
||||
[source (syntax-source stx)])
|
||||
[source (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))])
|
||||
(syntax (build-test name term expecteds #t #f line source)))]))
|
||||
|
||||
(define (build-test name term expecteds mz? around line source)
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
|
||||
(require racket/match
|
||||
racket/contract
|
||||
setup/path-to-relative
|
||||
(for-template racket/base racket/contract))
|
||||
|
||||
(define (parse-kw-args formals actuals source form-name)
|
||||
|
@ -36,16 +37,20 @@
|
|||
(syntax rest))]
|
||||
[else (raise-syntax-error #f "bad keyword argument syntax" source rest)])))
|
||||
|
||||
;; note: depents on current-directory (or current-load-relative-directory)
|
||||
(define (client-name stx form)
|
||||
(let ([m (syntax-source-module stx)])
|
||||
(cond [(module-path-index? m)
|
||||
(format "~a" (module-path-index-resolve m))]
|
||||
[(or (symbol? m) (path? m))
|
||||
(format "~a" m)]
|
||||
[else (format "~s client" form)])))
|
||||
(define mpi/path/sym (syntax-source-module stx))
|
||||
(define pth/sym (if (module-path-index? mpi/path/sym)
|
||||
(resolved-module-path-name
|
||||
(module-path-index-resolve mpi/path/sym))
|
||||
mpi/path/sym))
|
||||
(if (path? pth/sym)
|
||||
(path->relative-string/library pth/sym)
|
||||
(format "~s" pth/sym)))
|
||||
|
||||
(define (src-loc-stx stx)
|
||||
#`#(#,(syntax-source stx)
|
||||
#`#(#,(and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
|
@ -56,4 +61,7 @@
|
|||
#,(client-name expr form) '#,form
|
||||
#,desc #,(src-loc-stx expr)))
|
||||
|
||||
(provide (all-defined-out))
|
||||
(provide src-loc-stx
|
||||
apply-contract
|
||||
client-name
|
||||
parse-kw-args)
|
||||
|
|
|
@ -4,9 +4,6 @@
|
|||
;;
|
||||
;; -- jay's idea
|
||||
;;
|
||||
;; -- when a pattern has no bindings, just use 'and's
|
||||
;; and 'or's to check for the match (no allocation)
|
||||
;;
|
||||
;; -- when a list pattern has only a single repeat,
|
||||
;; don't search for matches, just count
|
||||
;;
|
||||
|
@ -25,15 +22,15 @@
|
|||
;; we don't return all of the bogus matches that show up
|
||||
;; by treating the hole as 'any'.
|
||||
;;
|
||||
;; (this one turns out not to be so great because it
|
||||
;; makes caching less effective)
|
||||
;;
|
||||
;; -- combine the left-hand sides of a reduction relation
|
||||
;; so to avoid re-doing decompositions over and over
|
||||
;; (maybe....)
|
||||
;;
|
||||
;; -- parallelism? but what about the hash-table?
|
||||
;; -- parallelism? but what about the hash-table cache?
|
||||
;;
|
||||
;; -- double check the caching code to make sure it makes
|
||||
;; sense in the current uni-hole world
|
||||
|
||||
#|
|
||||
|
||||
Note: the patterns described in the documentation are
|
||||
|
|
|
@ -6,7 +6,8 @@
|
|||
"fresh.rkt"
|
||||
"loc-wrapper.rkt"
|
||||
"error.rkt"
|
||||
(for-syntax "cycle-check.rkt")
|
||||
(for-syntax "cycle-check.rkt"
|
||||
setup/path-to-relative)
|
||||
racket/trace
|
||||
racket/contract
|
||||
racket/list
|
||||
|
@ -973,7 +974,8 @@
|
|||
(with-syntax ([(lhs-w/extras (w/extras-names ...) (w/extras-names/ellipses ...))
|
||||
(rw-sc #`(side-condition #,from #,test-case-body-code))]
|
||||
[lhs-source (format "~a:~a:~a"
|
||||
(syntax-source from)
|
||||
(and (path? (syntax-source from))
|
||||
(path->relative-string/library (syntax-source from)))
|
||||
(syntax-line from)
|
||||
(syntax-column from))]
|
||||
[name name]
|
||||
|
@ -1537,7 +1539,8 @@
|
|||
[(clause-src ...)
|
||||
(map (λ (lhs)
|
||||
(format "~a:~a:~a"
|
||||
(syntax-source lhs)
|
||||
(and (path? (syntax-source lhs))
|
||||
(path->relative-string/library (syntax-source lhs)))
|
||||
(syntax-line lhs)
|
||||
(syntax-column lhs)))
|
||||
pats)]
|
||||
|
@ -2613,6 +2616,9 @@
|
|||
(hash-map new-ht (λ (x y) y))
|
||||
(compiled-lang-nt-map old-lang))))
|
||||
|
||||
(define (union-language lang1 lang2)
|
||||
(void))
|
||||
|
||||
;; find-primary-nt : symbol lang -> symbol or #f
|
||||
;; returns the primary non-terminal for a given nt, or #f if `nt' isn't bound in the language.
|
||||
(define (find-primary-nt nt lang)
|
||||
|
@ -2755,7 +2761,8 @@
|
|||
|
||||
(define-for-syntax (get-srcloc stx)
|
||||
#`(list
|
||||
'#,(syntax-source stx)
|
||||
'#,(and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))
|
||||
'#,(syntax-line stx)
|
||||
'#,(syntax-column stx)
|
||||
'#,(syntax-position stx)))
|
||||
|
@ -2909,9 +2916,7 @@
|
|||
[pos (list-ref srcinfo 3)])
|
||||
(eprintf "FAILED ~a~a\n"
|
||||
(cond
|
||||
[(path? file)
|
||||
(let-values ([(base name dir) (split-path file)])
|
||||
(path->string name))]
|
||||
[(string? file) file]
|
||||
[else ""])
|
||||
(cond
|
||||
[(and line column)
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
(require mzlib/list
|
||||
"underscore-allowed.rkt")
|
||||
(require "term.rkt"
|
||||
setup/path-to-relative
|
||||
(for-template
|
||||
mzscheme
|
||||
"term.rkt"
|
||||
|
@ -88,8 +89,20 @@
|
|||
name/ellipses)))
|
||||
pre-vars
|
||||
names/ellipses))]
|
||||
[src-loc (parameterize ([print-syntax-width 0])
|
||||
(format "~s" #'exp))])
|
||||
[src-loc
|
||||
(let ([stx #'exp])
|
||||
(define src (syntax-source stx))
|
||||
(define line (syntax-line stx))
|
||||
(define col (syntax-column stx))
|
||||
(format "~a:~a"
|
||||
(if (path? src)
|
||||
(path->relative-string/library src)
|
||||
"?")
|
||||
(if (and line col)
|
||||
(format "~a:~a" line col)
|
||||
(if line
|
||||
(format "~a:?" line)
|
||||
(syntax-position stx)))))])
|
||||
(values (syntax/loc term
|
||||
(side-condition
|
||||
pre-term
|
||||
|
|
|
@ -8,6 +8,7 @@
|
|||
"struct.rkt"
|
||||
"match-a-pattern.rkt"
|
||||
(for-syntax racket/base
|
||||
setup/path-to-relative
|
||||
"rewrite-side-conditions.rkt"
|
||||
"term-fn.rkt"
|
||||
"reduction-semantics.rkt"
|
||||
|
@ -810,7 +811,7 @@
|
|||
(with-syntax ([loc (if (and (path? (syntax-source stx))
|
||||
(syntax-line stx))
|
||||
(format "~a:~a"
|
||||
(path->string (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx))
|
||||
(syntax-line stx))
|
||||
#f)])
|
||||
#`(λ (msg)
|
||||
|
|
|
@ -5,7 +5,10 @@
|
|||
scribble/eval
|
||||
racket/runtime-path
|
||||
scriblib/autobib
|
||||
(for-syntax racket/base)
|
||||
(for-syntax racket/base
|
||||
setup/path-to-relative
|
||||
setup/main-collects)
|
||||
setup/dirs
|
||||
"tut-util.rkt"
|
||||
(for-label racket/base
|
||||
racket/gui
|
||||
|
@ -42,18 +45,7 @@
|
|||
@(define-for-syntax (loc stx)
|
||||
(let ([src (syntax-source stx)])
|
||||
(if (path? src)
|
||||
(apply
|
||||
build-path
|
||||
(reverse
|
||||
(let loop ([src src]
|
||||
[i 3])
|
||||
(cond
|
||||
[(zero? i) '()]
|
||||
[else
|
||||
(define-values (base name dir) (split-path src))
|
||||
(if base
|
||||
(cons name (loop base (- i 1)))
|
||||
(list name))]))))
|
||||
(path->relative-string/library src)
|
||||
#f)))
|
||||
@(define-syntax (interaction/test stx)
|
||||
(syntax-case stx ()
|
||||
|
@ -484,20 +476,58 @@ relation for our @racket[amb] language, we first need to define
|
|||
the evaluation contexts and values, so we extend the
|
||||
language a second time.
|
||||
|
||||
@racketblock+eval[#:eval
|
||||
amb-eval
|
||||
(define-extended-language Ev L+Γ
|
||||
(p (e ...))
|
||||
(P (e ... E e ...))
|
||||
(E (v E)
|
||||
(E e)
|
||||
(+ v ... E e ...)
|
||||
(if0 E e e)
|
||||
(fix E)
|
||||
hole)
|
||||
(v (λ (x t) e)
|
||||
(fix v)
|
||||
number))]
|
||||
|
||||
@; these definitions are just like racketblock+eval, but also
|
||||
@; preserve source locations so we can show typesetting
|
||||
@; examples in a later section
|
||||
@(require syntax/strip-context)
|
||||
@(define-syntax (m stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg)
|
||||
(let ()
|
||||
(define rewritten
|
||||
(let loop ([stx #'arg])
|
||||
(cond
|
||||
[(syntax? stx) #`(datum->syntax #f
|
||||
#,(loop (syntax-e stx))
|
||||
(vector (convert-to-path
|
||||
'#,(and (path? (syntax-source stx))
|
||||
(path->main-collects-relative (syntax-source stx))))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))]
|
||||
[(pair? stx) #`(cons #,(loop (car stx))
|
||||
#,(loop (cdr stx)))]
|
||||
[(or (symbol? stx) (null? stx)
|
||||
(number? stx) (keyword? stx)
|
||||
(string? stx))
|
||||
#`'#,stx]
|
||||
[else (error 'm "unk ~s" stx)])))
|
||||
#`(let ()
|
||||
(amb-eval #,rewritten)
|
||||
(racketblock arg)))]))
|
||||
@(define (convert-to-path src)
|
||||
(cond
|
||||
[(path? src) src]
|
||||
[(not src) src]
|
||||
[else
|
||||
(apply build-path
|
||||
(find-collects-dir)
|
||||
(map bytes->path (cdr src)))]))
|
||||
|
||||
@m[(define-extended-language Ev L+Γ
|
||||
(p (e ...))
|
||||
(P (e ... E e ...))
|
||||
(E (v E)
|
||||
(E e)
|
||||
(+ v ... E e ...)
|
||||
(if0 E e e)
|
||||
(fix E)
|
||||
hole)
|
||||
(v (λ (x t) e)
|
||||
(fix v)
|
||||
number))]
|
||||
|
||||
To give a suitable notion of evaluation for @racket[amb], we define
|
||||
@racket[p], a non-terminal for programs. Each program consists of a
|
||||
|
@ -576,35 +606,6 @@ supply directly to @racket[subst/proc]).
|
|||
|
||||
Using that substitution function, we can now give the reduction relation.
|
||||
|
||||
@; these definitions are just like racketblock+eval, but also
|
||||
@; preserve source locations so we can show typesetting
|
||||
@; examples in a later section
|
||||
@(require syntax/strip-context)
|
||||
@(define-syntax (m stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg)
|
||||
(let ()
|
||||
(define rewritten
|
||||
(let loop ([stx #'arg])
|
||||
(cond
|
||||
[(syntax? stx) #`(datum->syntax #f
|
||||
#,(loop (syntax-e stx))
|
||||
(vector #,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))]
|
||||
[(pair? stx) #`(cons #,(loop (car stx))
|
||||
#,(loop (cdr stx)))]
|
||||
[(or (symbol? stx) (null? stx)
|
||||
(number? stx) (keyword? stx)
|
||||
(string? stx))
|
||||
#`'#,stx]
|
||||
[else (error 'm "unk ~s" stx)])))
|
||||
#`(let ()
|
||||
(amb-eval #,rewritten)
|
||||
(racketblock arg)))]))
|
||||
|
||||
@m[(define red
|
||||
(reduction-relation
|
||||
Ev
|
||||
|
@ -1026,6 +1027,27 @@ a different set of strings and @racket[lw]s. For more details on the structure o
|
|||
|
||||
@exercise[]
|
||||
|
||||
Redex uses the indentation and newlines in the program source code to
|
||||
determine where the line breaks in the printed output goes, instead of
|
||||
using a pretty-printer, so as to give Redex programmers fine-grained
|
||||
control over how their models typeset.
|
||||
|
||||
Exploit this facility so that this expression produces an expression
|
||||
with a minimum amount of whitespace within its bounding box.
|
||||
(The call to @racket[frame] helps to clarify where the bounding
|
||||
box is.)
|
||||
|
||||
@racketblock[(frame
|
||||
(vl-append
|
||||
20
|
||||
(language->pict Ev)
|
||||
(reduction-relation->pict red)))]
|
||||
|
||||
That is, adjust the whitespace in @racket[Ev] so that it
|
||||
fills as much of the width established by rendering @racket[red].
|
||||
|
||||
@exercise[]
|
||||
|
||||
Typeset @racket[types]. Use a compound rewriter so a use of @racket[(type Γ e t)]
|
||||
is rendered as @racketblock[Γ ⊢ e : t]
|
||||
|
||||
|
|
|
@ -3,7 +3,9 @@
|
|||
(require "test-util.rkt"
|
||||
drracket/check-syntax
|
||||
redex/pict
|
||||
redex/reduction-semantics)
|
||||
redex/reduction-semantics
|
||||
(for-syntax setup/path-to-relative)
|
||||
setup/path-to-relative)
|
||||
|
||||
(reset-count)
|
||||
|
||||
|
@ -18,10 +20,13 @@
|
|||
#,(syntax-line #'x)
|
||||
#,(syntax-column #'x)
|
||||
#,(syntax-position #'x))
|
||||
(read-syntax '#,(syntax-source #'x) p))]))
|
||||
(read-syntax '#,(and (path? (syntax-source #'x))
|
||||
(path->relative-string/library (syntax-source #'x)))
|
||||
p))]))
|
||||
|
||||
(define (source stx)
|
||||
(list (syntax-source stx)
|
||||
(list (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)))
|
||||
|
||||
|
|
|
@ -1,9 +1,10 @@
|
|||
#lang scheme
|
||||
|
||||
(require "../private/matcher.rkt"
|
||||
(for-syntax syntax/parse)
|
||||
(for-syntax syntax/parse setup/path-to-relative)
|
||||
errortrace/errortrace-lib
|
||||
errortrace/errortrace-key
|
||||
setup/path-to-relative
|
||||
racket/runtime-path)
|
||||
(provide test test-syn-err tests reset-count
|
||||
syn-err-test-namespace
|
||||
|
@ -31,7 +32,7 @@
|
|||
[(_ expected got)
|
||||
(with-syntax ([line (syntax-line stx)]
|
||||
[fn (if (path? (syntax-source (syntax got)))
|
||||
(path->string (syntax-source (syntax got)))
|
||||
(path->relative-string/library (syntax-source (syntax got)))
|
||||
"<unknown file>")])
|
||||
(syntax/loc stx (test/proc (λ () expected) got line fn)))]))
|
||||
|
||||
|
@ -74,7 +75,8 @@
|
|||
[(message named-pieces body)
|
||||
(make-error-test (syntax/loc spec (message named-pieces () body)))]
|
||||
[(message ([loc-name loc-piece] ...) ([non-loc-name non-loc-piece] ...) body)
|
||||
(values (syntax-source spec)
|
||||
(values (and (path? (syntax-source spec))
|
||||
(path->relative-string/library (syntax-source spec)))
|
||||
(syntax-line spec)
|
||||
(syntax-e #'message)
|
||||
(map source-location (syntax->list #'(loc-piece ...)))
|
||||
|
@ -87,7 +89,8 @@
|
|||
(void)))]))
|
||||
|
||||
(define (source-location stx)
|
||||
(list (syntax-source stx)
|
||||
(list (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
|
|
Loading…
Reference in New Issue
Block a user