suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust beaucoup places in redex where the source was being

Browse Source 
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:
Robby Findler 2012-02-08 09:31:48 -06:00
parent ed22a630fd
commit 55b3d99d78
10 changed files with 155 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/redex/examples/arithmetic.rkt
View File

@ -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)]))

15
collects/redex/examples/r6rs/test.rkt
View File

@ -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)

24
collects/redex/private/keyword-macros.rkt
View File

@ -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)

11
collects/redex/private/matcher.rkt
View File

@ -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

19
collects/redex/private/reduction-semantics.rkt
View File

@ -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)

17
collects/redex/private/rewrite-side-conditions.rkt
View File

@ -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

3
collects/redex/private/rg.rkt
View File

@ -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)

134
collects/redex/private/tut.scrbl
View File

@ -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]

11
collects/redex/tests/check-syntax-test.rkt
View File

@ -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)))

11
collects/redex/tests/test-util.rkt
View File

@ -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)